diff --git a/base/serial/impl/psb_z_csrli_impl.f90 b/base/serial/impl/psb_z_csrli_impl.f90 new file mode 100644 index 00000000..3300a7d3 --- /dev/null +++ b/base/serial/impl/psb_z_csrli_impl.f90 @@ -0,0 +1,3151 @@ +! +! 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_z_csrli_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_csmv + implicit none + class(psb_z_csrli_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), 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_z_csrli_csmm + implicit none + class(psb_z_csrli_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), 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_dpk_), 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_z_csrli_cssv + implicit none + class(psb_z_csrli_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer(psb_ipk_) :: i,k,m + complex(psb_dpk_), 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_z_csrli_cssm + implicit none + class(psb_z_csrli_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), 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_dpk_), 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 == zzero) then + if (beta == zzero) then + do i = 1, m + y(i,:) = zzero + enddo + else + do i = 1, m + y(i,:) = beta*y(i,:) + end do + endif + return + end if + + if (beta == zzero) 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_dpk_), intent(in) :: val(*), x(ldx,*) + complex(psb_dpk_), intent(out) :: y(ldy,*) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i,j, jc + complex(psb_dpk_), 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 = zzero + 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 = zzero + 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 = zzero + 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 = zzero + 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_z_csrli_cssm + +function psb_z_csrli_maxval(a) result(res) + use psb_error_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_maxval + implicit none + class(psb_z_csrli_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: nnz, nc + 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() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_z_csrli_maxval + +function psb_z_csrli_csnmi(a) result(res) + use psb_error_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_csnmi + implicit none + class(psb_z_csrli_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: i,j + real(psb_dpk_) :: 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 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_z_csrli_csnmi + +subroutine psb_z_csrli_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_rowsum + class(psb_z_csrli_sparse_mat), intent(in) :: a + complex(psb_dpk_), 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) = zzero + 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) + zone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_csrli_rowsum + +subroutine psb_z_csrli_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_arwsum + class(psb_z_csrli_sparse_mat), intent(in) :: a + real(psb_dpk_), 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 + d(i) = d(i) + abs(a%val(j)) + 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_z_csrli_arwsum + +subroutine psb_z_csrli_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_colsum + class(psb_z_csrli_sparse_mat), intent(in) :: a + complex(psb_dpk_), 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 = zzero + + 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) + zone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_csrli_colsum + +subroutine psb_z_csrli_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_aclsum + class(psb_z_csrli_sparse_mat), intent(in) :: a + real(psb_dpk_), 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) + d(k) = d(k) + abs(a%val(j)) + 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_z_csrli_aclsum + +subroutine psb_z_csrli_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_get_diag + implicit none + class(psb_z_csrli_sparse_mat), intent(in) :: a + complex(psb_dpk_), 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) = zone + end do + else + !$omp parallel do private(i,j,k) + do i=1, mnm + d(i) = zzero + 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) + endif + enddo + end do + end if + !$omp parallel do private(i) + do i=mnm+1,size(d) + d(i) = zzero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_z_csrli_get_diag + + +subroutine psb_z_csrli_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_scal + use psb_string_mod + implicit none + class(psb_z_csrli_sparse_mat), intent(inout) :: a + complex(psb_dpk_), 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. + + 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 + + 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_z_csrli_scal + + +subroutine psb_z_csrli_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_scals + implicit none + class(psb_z_csrli_sparse_mat), intent(inout) :: a + complex(psb_dpk_), 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 + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_z_csrli_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_z_csrli_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_reallocate_nz + implicit none + integer(psb_ipk_), intent(in) :: nz + class(psb_z_csrli_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='z_csrli_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_csrli_reallocate_nz + +subroutine psb_z_csrli_mold(a,b,info) + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_mold + use psb_error_mod + implicit none + class(psb_z_csrli_sparse_mat), intent(in) :: a + class(psb_z_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_z_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_z_csrli_mold + +subroutine psb_z_csrli_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_allocate_mnnz + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_csrli_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info, nz_ + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_csrli_allocate_mnnz + + +subroutine psb_z_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_z_base_mat_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_csgetrow + implicit none + + class(psb_z_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_dpk_), 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_z_csrli_tril + implicit none + + class(psb_z_csrli_sparse_mat), intent(in) :: a + class(psb_z_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_z_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) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + 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) + l%val(nzin) = val(k) + 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_z_csrli_tril + +subroutine psb_z_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_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_triu + implicit none + + class(psb_z_csrli_sparse_mat), intent(in) :: a + class(psb_z_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_z_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) + u%val(nzin) = val(k) + 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_z_csrli_triu + + +subroutine psb_z_csrli_reinit(a,clear) + use psb_error_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_reinit + implicit none + + class(psb_z_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=zzero + else if (a%is_asb()) then + if (clear_) a%lambda=zzero + if (clear_) a%val(:) = zzero + 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_z_csrli_reinit + + +subroutine psb_z_csrli_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_z_base_mat_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_csrli_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_z_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_z_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 + write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) + 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 + write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) + 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 + write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) + 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 + write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) + 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 + write(iout,frmt) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_z_csrli_print + + +subroutine psb_z_cp_csrli_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_cp_csrli_from_coo + implicit none + + class(psb_z_csrli_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_z_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. + + !$ integer(psb_ipk_), allocatable :: sum(:) + !$ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s,j + !$ integer(psb_ipk_) :: nxt_val,old_val,saved_elem,maxthreads + !$ use_openmp = .true. + + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_z_base_sparse_mat = tmp%psb_z_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + +!!$ if (use_openmp) then +!!$ !$ maxthreads = omp_get_max_threads() +!!$ !$ allocate(sum(maxthreads+1)) +!!$ !$ sum(:) = 0 +!!$ !$ sum(1) = 1 +!!$ +!!$ !$OMP PARALLEL default(none) & +!!$ !$OMP shared(nza,itemp,a,nthreads,sum,nr) & +!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) +!!$ +!!$ !$OMP DO schedule(STATIC) & +!!$ !$OMP private(k,i) +!!$ do k=1,nza +!!$ i = itemp(k) +!!$ a%irp(i) = a%irp(i) + 1 +!!$ end do +!!$ !$OMP END DO +!!$ +!!$ !$OMP SINGLE +!!$ !$ nthreads = omp_get_num_threads() +!!$ !$OMP END SINGLE +!!$ +!!$ !$ ithread = omp_get_thread_num() +!!$ +!!$ !$ work = nr/nthreads +!!$ !$ if (ithread < MOD(nr,nthreads)) then +!!$ !$ work = work + 1 +!!$ !$ first_idx = ithread*work + 1 +!!$ !$ else +!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 +!!$ !$ end if +!!$ +!!$ !$ last_idx = first_idx + work - 1 +!!$ +!!$ !$ s = 0 +!!$ !$ do i=first_idx,last_idx +!!$ !$ s = s + a%irp(i) +!!$ !$ end do +!!$ !$ if (work > 0) then +!!$ !$ sum(ithread+2) = s +!!$ !$ end if +!!$ +!!$ !$OMP BARRIER +!!$ +!!$ !$OMP SINGLE +!!$ !$ do i=2,nthreads+1 +!!$ !$ sum(i) = sum(i) + sum(i-1) +!!$ !$ end do +!!$ !$OMP END SINGLE +!!$ +!!$ !$ if (work > 0) then +!!$ !$ saved_elem = a%irp(first_idx) +!!$ !$ end if +!!$ !$ if (ithread == 0) then +!!$ !$ a%irp(1) = 1 +!!$ !$ end if +!!$ +!!$ !$OMP BARRIER +!!$ +!!$ !$ if (work > 0) then +!!$ !$ old_val = a%irp(first_idx+1) +!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) +!!$ !$ end if +!!$ +!!$ !$ do i=first_idx+2,last_idx+1 +!!$ !$ nxt_val = a%irp(i) +!!$ !$ a%irp(i) = a%irp(i-1) + old_val +!!$ !$ old_val = nxt_val +!!$ !$ end do +!!$ +!!$ !$OMP END PARALLEL +!!$ else + + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip +!!$ end if + call a%set_host() + + +end subroutine psb_z_cp_csrli_from_coo + + + +subroutine psb_z_cp_csrli_to_coo(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_cp_csrli_to_coo + implicit none + + class(psb_z_csrli_sparse_mat), intent(in) :: a + class(psb_z_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_z_base_sparse_mat = a%psb_z_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) + b%val(j) = a%val(j) + 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_z_cp_csrli_to_coo + + +subroutine psb_z_mv_csrli_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_mv_csrli_to_coo + implicit none + + class(psb_z_csrli_sparse_mat), intent(inout) :: a + class(psb_z_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_z_base_sparse_mat = a%psb_z_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 + 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_z_mv_csrli_to_coo + + + +subroutine psb_z_mv_csrli_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_mv_csrli_from_coo + implicit none + + class(psb_z_csrli_sparse_mat), intent(inout) :: a + class(psb_z_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. + + ! $ integer(psb_ipk_), allocatable :: sum(:) + ! $ integer(psb_ipk_) :: first_idx,last_idx,work,ithread,nthreads,s + ! $ integer(psb_ipk_) :: nxt_val,old_val,saved_elem + ! $ use_openmp = .true. + + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + +!!$ if (use_openmp) then +!!$ !$OMP PARALLEL default(none) & +!!$ !$OMP shared(sum,nthreads,nr,a,itemp,nza) & +!!$ !$OMP private(ithread,work,first_idx,last_idx,s,saved_elem,nxt_val,old_val) +!!$ +!!$ !$OMP DO schedule(STATIC) & +!!$ !$OMP private(k,i) +!!$ do k=1,nza +!!$ i = itemp(k) +!!$ a%irp(i) = a%irp(i) + 1 +!!$ end do +!!$ !$OMP END DO +!!$ +!!$ !$OMP SINGLE +!!$ !$ nthreads = omp_get_num_threads() +!!$ !$ allocate(sum(nthreads+1)) +!!$ !$ sum(:) = 0 +!!$ !$ sum(1) = 1 +!!$ !$OMP END SINGLE +!!$ +!!$ !$ ithread = omp_get_thread_num() +!!$ +!!$ !$ work = nr/nthreads +!!$ !$ if (ithread < MOD(nr,nthreads)) then +!!$ !$ work = work + 1 +!!$ !$ first_idx = ithread*work + 1 +!!$ !$ else +!!$ !$ first_idx = ithread*work + MOD(nr,nthreads) + 1 +!!$ !$ end if +!!$ +!!$ !$ last_idx = first_idx + work - 1 +!!$ +!!$ !$ s = 0 +!!$ !$ do i=first_idx,last_idx +!!$ !$ s = s + a%irp(i) +!!$ !$ end do +!!$ !$ if (work > 0) then +!!$ !$ sum(ithread+2) = s +!!$ !$ end if +!!$ +!!$ !$OMP BARRIER +!!$ +!!$ !$OMP SINGLE +!!$ !$ do i=2,nthreads+1 +!!$ !$ sum(i) = sum(i) + sum(i-1) +!!$ !$ end do +!!$ !$OMP END SINGLE +!!$ +!!$ !$ if (work > 0) then +!!$ !$ saved_elem = a%irp(first_idx) +!!$ !$ end if +!!$ !$ if (ithread == 0) then +!!$ !$ a%irp(1) = 1 +!!$ !$ end if +!!$ +!!$ !$ if (work > 0) then +!!$ !$ old_val = a%irp(first_idx+1) +!!$ !$ a%irp(first_idx+1) = saved_elem + sum(ithread+1) +!!$ !$ end if +!!$ +!!$ !$ do i=first_idx+2,last_idx+1 +!!$ !$ nxt_val = a%irp(i) +!!$ !$ a%irp(i) = a%irp(i-1) + old_val +!!$ !$ old_val = nxt_val +!!$ !$ end do +!!$ +!!$ !$OMP END PARALLEL +!!$ else + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip +!!$ end if + + call a%set_host() + +end subroutine psb_z_mv_csrli_from_coo + + +subroutine psb_z_mv_csrli_to_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_mv_csrli_to_fmt + implicit none + + class(psb_z_csrli_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_z_csrli_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_mv_csrli_to_fmt + + +subroutine psb_z_cp_csrli_to_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_realloc_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_cp_csrli_to_fmt + implicit none + + class(psb_z_csrli_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_z_csrli_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_cp_csrli_to_fmt + + +subroutine psb_z_mv_csrli_from_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_mv_csrli_from_fmt + implicit none + + class(psb_z_csrli_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_z_csrli_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_mv_csrli_from_fmt + + + +subroutine psb_z_cp_csrli_from_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_realloc_mod + use psb_z_csrli_mat_mod, psb_protect_name => psb_z_cp_csrli_from_fmt + implicit none + + class(psb_z_csrli_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_ipk_) :: nz, nr, i,j,irw, err_act, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_z_csrli_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_z_cp_csrli_from_fmt + +!!$ +!!$subroutine psb_zcsrlispspmm(a,b,c,info) +!!$ use psb_z_mat_mod +!!$ use psb_serial_mod, psb_protect_name => psb_zcsrlispspmm +!!$ +!!$ implicit none +!!$ +!!$ class(psb_z_csrli_sparse_mat), intent(in) :: a,b +!!$ type(psb_z_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_z_csrli_sparse_mat), intent(in) :: a,b +!!$ type(psb_z_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_dpk_), allocatable :: row(:) +!!$ integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & +!!$ & nzc,nnzre, isz, ipb, irwsz, nrc, nze +!!$ complex(psb_dpk_) :: 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_zcsrlispspmm +