From a879a0f69efb354ddd94ba80a1cdb3f862b4f276 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 6 Dec 2022 07:28:17 -0500 Subject: [PATCH] Defined C_CSRLI --- base/serial/impl/Makefile | 2 +- base/serial/impl/psb_c_csrli_impl.f90 | 2739 +++++++++++++++++++++++++ base/serial/impl/psb_z_csrli_impl.f90 | 2 +- 3 files changed, 2741 insertions(+), 2 deletions(-) create mode 100644 base/serial/impl/psb_c_csrli_impl.f90 diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index 87c26ebe..81faff79 100644 --- a/base/serial/impl/Makefile +++ b/base/serial/impl/Makefile @@ -13,7 +13,7 @@ SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o #\ psb_d_lcoo_impl.o psb_d_lcsr_impl.o -COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o +COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o psb_c_csrli_impl.o #\ psb_c_lcoo_impl.o psb_c_lcsr_impl.o ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o psb_z_csrli_impl.o diff --git a/base/serial/impl/psb_c_csrli_impl.f90 b/base/serial/impl/psb_c_csrli_impl.f90 new file mode 100644 index 00000000..3269677c --- /dev/null +++ b/base/serial/impl/psb_c_csrli_impl.f90 @@ -0,0 +1,2739 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_c_csrli_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_csmv + implicit none + class(psb_c_csrli_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer(psb_ipk_) :: m, n + logical :: tra, ctra + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='z_csrli_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra.or.ctra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_c_csrli_csmm + implicit none + class(psb_c_csrli_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer(psb_ipk_) :: j,m,n, nc + complex(psb_spk_), allocatable :: acc(:) + logical :: tra, ctra + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='z_csrli_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra.or.ctra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_c_csrli_cssv + implicit none + class(psb_c_csrli_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer(psb_ipk_) :: i,k,m + complex(psb_spk_), allocatable :: tmp(:) + logical :: tra,ctra + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='z_csrli_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x) psb_c_csrli_cssm + implicit none + class(psb_c_csrli_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer(psb_ipk_) :: i,k,m, nc + complex(psb_spk_), allocatable :: tmp(:,:) + logical :: tra, ctra + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_csrli_cssm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_dev()) call a%sync() + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + m = a%get_nrows() + nc = min(size(x,2) , size(y,2)) + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == czero) then + if (beta == czero) then + do i = 1, m + y(i,:) = czero + enddo + else + do i = 1, m + y(i,:) = beta*y(i,:) + end do + endif + return + end if + + if (beta == czero) then + call inner_csrlism(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_csrlism(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_csrlism') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine inner_csrlism(tra,ctra,lower,unit,nr,nc,& + & irp,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,ctra,lower,unit + integer(psb_ipk_), intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) + complex(psb_spk_), intent(in) :: val(*), x(ldx,*) + complex(psb_spk_), intent(out) :: y(ldy,*) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i,j, jc + complex(psb_spk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if ((.not.tra).and.(.not.ctra)) then + if (lower) then + if (unit) then + do i=1, nr + acc = czero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=1, nr + acc = czero + do j=irp(i), irp(i+1)-2 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/(val(irp(i+1)-1)+a%lambda) + end do + end if + else if (.not.lower) then + + if (unit) then + do i=nr, 1, -1 + acc = czero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=nr, 1, -1 + acc = czero + do j=irp(i)+1, irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/(val(irp(i))+a%lambda) + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + do i=nr, 1, -1 + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=nr, 1, -1 + y(i,1:nc) = y(i,1:nc)/(val(irp(i+1)-1)+a%lambda) + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, nr + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=1, nr + y(i,1:nc) = y(i,1:nc)/(val(irp(i))+a%lambda) + acc = y(i,1:nc) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + + end if + + else if (ctra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + do i=nr, 1, -1 + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=nr, 1, -1 + y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i+1)-1)+a%lambda) + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, nr + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=1, nr + y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i))+a%lambda) + acc = y(i,1:nc) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + end if + + end if + end if + end subroutine inner_csrlism + +end subroutine psb_c_csrli_cssm + +function psb_c_csrli_maxval(a) result(res) + use psb_error_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_maxval + implicit none + class(psb_c_csrli_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: nnz, nc, i,j,nr + integer(psb_ipk_) :: info + character(len=20) :: name='z_csrli_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + nr = a%get_nrows() + if (allocated(a%val)) then + do i=1, nr + do j=a%irp(i), a%irp(i+1)-1 + if (a%ja(j) == i) then + res = max(abs(a%val(j)+a%lambda),res) + else + res = max(abs(a%val(j)),res) + endif + end do + end do + end if +end function psb_c_csrli_maxval + +function psb_c_csrli_csnmi(a) result(res) + use psb_error_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_csnmi + implicit none + class(psb_c_csrli_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: i,j + real(psb_spk_) :: acc + logical :: tra + character(len=20) :: name='z_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + + !$omp parallel do private(i,j,acc) reduction(max: res) + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + if (a%ja(j) == i) then + acc = acc + abs(a%val(j)+a%lambda) + else + acc = acc + abs(a%val(j)) + end if + end do + res = max(res,acc) + end do + +end function psb_c_csrli_csnmi + +subroutine psb_c_csrli_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_rowsum + class(psb_c_csrli_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: i,j,k,m + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + ierr(1) = 1; ierr(2) = size(d); ierr(3) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = a%lambda + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + cone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_csrli_rowsum + +subroutine psb_c_csrli_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_arwsum + class(psb_c_csrli_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: i,j,m + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + ierr(1) = 1; ierr(2) = size(d); ierr(3) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + if (a%ja(j) == i) then + d(i) = d(i) + abs(a%val(j)+a%lambda) + else + d(i) = d(i) + abs(a%val(j)) + end if + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_csrli_arwsum + +subroutine psb_c_csrli_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_colsum + class(psb_c_csrli_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: i,j,k,m,n + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + ierr(1) = 1; ierr(2) = size(d); ierr(3) = n + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + d = a%lambda + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + cone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_csrli_colsum + +subroutine psb_c_csrli_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_aclsum + class(psb_c_csrli_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: i,j,k,m,n, nnz + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + ierr(1) = 1; ierr(2) = size(d); ierr(3) = n + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + if (k == i) then + d(k) = d(k) + abs(a%val(j)+a%lambda) + else + d(k) = d(k) + abs(a%val(j)) + end if + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_csrli_aclsum + +subroutine psb_c_csrli_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_get_diag + implicit none + class(psb_c_csrli_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, mnm, i, j, k + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + !$omp parallel do private(i) + do i=1, mnm + d(i) = cone + end do + else + !$omp parallel do private(i,j,k) + do i=1, mnm + d(i) = a%lambda + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + a%lambda + endif + enddo + end do + end if + !$omp parallel do private(i) + do i=mnm+1,size(d) + d(i) = czero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_c_csrli_get_diag + + +subroutine psb_c_csrli_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_scal + use psb_string_mod + implicit none + class(psb_c_csrli_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act, i, j, m + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + integer(psb_ipk_) :: debug_level, debug_unit + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + write(debug_unit,*) ' There is no way to scale A+lambda I and keep lambda' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + +!!$ side_ = 'L' +!!$ if (present(side)) then +!!$ side_ = psb_toupper(side) +!!$ end if +!!$ +!!$ left = (side_ == 'L') +!!$ +!!$ if (left) then +!!$ m = a%get_nrows() +!!$ if (size(d) < m) then +!!$ info=psb_err_input_asize_invalid_i_ +!!$ ierr(1) = 2; ierr(2) = size(d); +!!$ call psb_errpush(info,name,i_err=ierr) +!!$ goto 9999 +!!$ end if +!!$ +!!$ !$omp parallel do private(i,j) +!!$ do i=1, m +!!$ do j = a%irp(i), a%irp(i+1) -1 +!!$ a%val(j) = a%val(j) * d(i) +!!$ end do +!!$ enddo +!!$ else +!!$ m = a%get_ncols() +!!$ if (size(d) < m) then +!!$ info=psb_err_input_asize_invalid_i_ +!!$ ierr(1) = 2; ierr(2) = size(d); +!!$ call psb_errpush(info,name,i_err=ierr) +!!$ goto 9999 +!!$ end if +!!$ +!!$ !$omp parallel do private(i,j) +!!$ do i=1,a%get_nzeros() +!!$ j = a%ja(i) +!!$ a%val(i) = a%val(i) * d(j) +!!$ enddo +!!$ end if +!!$ +!!$ call a%set_host() +!!$ + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_c_csrli_scal + + +subroutine psb_c_csrli_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_scals + implicit none + class(psb_c_csrli_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + !$omp parallel do private(i) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + a%lambda = a%lambda * d + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_c_csrli_scals + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_c_csrli_mold(a,b,info) + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_mold + use psb_error_mod + implicit none + class(psb_c_csrli_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csrli_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_c_csrli_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_c_csrli_mold + +subroutine psb_c_csrli_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_csgetrow + implicit none + + class(psb_c_csrli_sparse_mat), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale,chksz + + logical :: append_, rscale_, cscale_, chksz_ + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_c_csrli_tril + implicit none + + class(psb_c_csrli_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_c_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + if (ja(k) == i) then + l%val(nzlin) = val(k) + a%lambda + else + l%val(nzlin) = val(k) + end if + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + if (ja(k) == i) then + u%val(nzuin) = val(k) + a%lambda + else + u%val(nzuin) = val(k) + end if + end if + end if + end do + end do + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + if (ja(k) == i) then + l%val(nzlin) = val(k) + a%lambda + else + l%val(nzin) = val(k) + end if + end if + end if + end do + end do + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_csrli_tril + +subroutine psb_c_csrli_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_triu + implicit none + + class(psb_c_csrli_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_c_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k + integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + if (ja(k) == i) then + u%val(nzuin) = val(k) + a%lambda + else + u%val(nzin) = val(k) + end if + end if + end if + end do + end do + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_csrli_triu + + +subroutine psb_c_csrli_reinit(a,clear) + use psb_error_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_reinit + implicit none + + class(psb_c_csrli_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + if (clear_) a%lambda=czero + else if (a%is_asb()) then + if (clear_) a%lambda=czero + if (clear_) a%val(:) = czero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_csrli_reinit + + +subroutine psb_c_csrli_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_c_base_mat_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_csrli_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_c_csrli_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_csrli_print' + logical, parameter :: debug=.false. + character(len=80) :: frmt + integer(psb_ipk_) :: i,j, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + frmt = psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc) + + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + if (a%ja(j) == i) then + write(iout,frmt) iv(i),(a%ja(j)),a%val(j)+a%lambda + else + write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) + end if + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + if (a%ja(j) == i) then + write(iout,frmt) ivr(i),(a%ja(j)),a%val(j)+a%lambda + else + write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) + end if + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + if (a%ja(j) == i) then + write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j)+a%lambda + else + write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) + end if + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + if (a%ja(j) == i) then + write(iout,frmt) (i),ivc(a%ja(j)),a%val(j)+a%lambda + else + write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) + end if + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + if (a%ja(j) == i) then + write(iout,frmt) (i),(a%ja(j)),a%val(j)+a%lambda + else + write(iout,frmt) (i),(a%ja(j)),a%val(j) + end if + end do + enddo + endif + endif + +end subroutine psb_c_csrli_print + + +subroutine psb_c_cp_csrli_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_cp_csrli_from_coo + implicit none + + class(psb_c_csrli_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_c_coo_sparse_mat) :: tmp + integer(psb_ipk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_ipk_) :: nza, nr, nc, i,k,ip, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name='z_cp_csrli_from_coo' + logical :: use_openmp = .false. + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + call a%psb_c_csr_sparse_mat%cp_from_coo(b,info) + call a%set_lambda(czero) + call a%set_host() + +end subroutine psb_c_cp_csrli_from_coo + + + +subroutine psb_c_cp_csrli_to_coo(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_cp_csrli_to_coo + implicit none + + class(psb_c_csrli_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_ipk_) :: nza, nr, nc,i,j,irw, err_act + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + if (a%ja(j) == i) then + b%val(j) = a%val(j)+a%lambda + else + b%val(j) = a%val(j) + end if + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_c_cp_csrli_to_coo + + +subroutine psb_c_mv_csrli_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_mv_csrli_to_coo + implicit none + + class(psb_c_csrli_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_ipk_) :: nza, nr, nc,i,j,k,irw, err_act + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + if (b%ja(j) == i) then + b%val(j) = b%val(j) + a%lambda + end if + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_c_mv_csrli_to_coo + + + +subroutine psb_c_mv_csrli_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csrli_mat_mod, psb_protect_name => psb_c_mv_csrli_from_coo + implicit none + + class(psb_c_csrli_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_ipk_) :: nza, nr, nc, i,j,k, ip,irw, err_act, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name='mv_from_coo' + logical :: use_openmp = .false. + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call a%psb_c_csr_sparse_mat%mv_from_coo(b,info) + call a%set_lambda(czero) + call a%set_host() + +end subroutine psb_c_mv_csrli_from_coo + + +!!$ +!!$subroutine psb_ccsrlispspmm(a,b,c,info) +!!$ use psb_c_mat_mod +!!$ use psb_serial_mod, psb_protect_name => psb_ccsrlispspmm +!!$ +!!$ implicit none +!!$ +!!$ class(psb_c_csrli_sparse_mat), intent(in) :: a,b +!!$ type(psb_c_csrli_sparse_mat), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: ma,na,mb,nb, nzc, nza, nzb +!!$ character(len=20) :: name +!!$ integer(psb_ipk_) :: err_act +!!$ name='psb_csrlispspmm' +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ +!!$ if (a%is_dev()) call a%sync() +!!$ if (b%is_dev()) call b%sync() +!!$ +!!$ ma = a%get_nrows() +!!$ na = a%get_ncols() +!!$ mb = b%get_nrows() +!!$ nb = b%get_ncols() +!!$ +!!$ +!!$ if ( mb /= na ) then +!!$ write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb +!!$ info = psb_err_invalid_matrix_sizes_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ ! Estimate number of nonzeros on output. +!!$ nza = a%get_nzeros() +!!$ nzb = b%get_nzeros() +!!$ nzc = 2*(nza+nzb) +!!$ call c%allocate(ma,nb,nzc) +!!$ +!!$ call csrli_spspmm(a,b,c,info) +!!$ +!!$ call c%set_asb() +!!$ call c%set_host() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$contains +!!$ +!!$ subroutine csrli_spspmm(a,b,c,info) +!!$ implicit none +!!$ type(psb_c_csrli_sparse_mat), intent(in) :: a,b +!!$ type(psb_c_csrli_sparse_mat), intent(inout) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: ma,na,mb,nb +!!$ integer(psb_ipk_), allocatable :: irow(:), idxs(:) +!!$ complex(psb_spk_), allocatable :: row(:) +!!$ integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & +!!$ & nzc,nnzre, isz, ipb, irwsz, nrc, nze +!!$ complex(psb_spk_) :: cfb +!!$ +!!$ +!!$ info = psb_success_ +!!$ ma = a%get_nrows() +!!$ na = a%get_ncols() +!!$ mb = b%get_nrows() +!!$ nb = b%get_ncols() +!!$ +!!$ nze = min(size(c%val),size(c%ja)) +!!$ isz = max(ma,na,mb,nb) +!!$ call psb_realloc(isz,row,info) +!!$ if (info == 0) call psb_realloc(isz,idxs,info) +!!$ if (info == 0) call psb_realloc(isz,irow,info) +!!$ if (info /= 0) return +!!$ row = dzero +!!$ irow = 0 +!!$ nzc = 1 +!!$ do j = 1,ma +!!$ c%irp(j) = nzc +!!$ nrc = 0 +!!$ do k = a%irp(j), a%irp(j+1)-1 +!!$ irw = a%ja(k) +!!$ cfb = a%val(k) +!!$ irwsz = b%irp(irw+1)-b%irp(irw) +!!$ do i = b%irp(irw),b%irp(irw+1)-1 +!!$ icl = b%ja(i) +!!$ if (irow(icl) 0 ) then +!!$ if ((nzc+nrc)>nze) then +!!$ nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) +!!$ call psb_realloc(nze,c%val,info) +!!$ if (info == 0) call psb_realloc(nze,c%ja,info) +!!$ if (info /= 0) return +!!$ end if +!!$ +!!$ call psb_qsort(idxs(1:nrc)) +!!$ do i=1, nrc +!!$ irw = idxs(i) +!!$ c%ja(nzc) = irw +!!$ c%val(nzc) = row(irw) +!!$ row(irw) = dzero +!!$ nzc = nzc + 1 +!!$ end do +!!$ end if +!!$ end do +!!$ +!!$ c%irp(ma+1) = nzc +!!$ +!!$ +!!$ end subroutine csrli_spspmm +!!$ +!!$end subroutine psb_ccsrlispspmm + diff --git a/base/serial/impl/psb_z_csrli_impl.f90 b/base/serial/impl/psb_z_csrli_impl.f90 index 9d98001f..e9bc7dad 100644 --- a/base/serial/impl/psb_z_csrli_impl.f90 +++ b/base/serial/impl/psb_z_csrli_impl.f90 @@ -2676,7 +2676,7 @@ end subroutine psb_z_mv_csrli_from_coo !!$ complex(psb_dpk_), allocatable :: row(:) !!$ integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & !!$ & nzc,nnzre, isz, ipb, irwsz, nrc, nze -!!$ complex(psb_dpk_) :: cfb +!!$ complex(psb_dpk_) :: cfb !!$ !!$ !!$ info = psb_success_