diff --git a/test/serial/d_matgen.f03 b/test/serial/d_matgen.f03 index 85d33b95..2eadbc6c 100644 --- a/test/serial/d_matgen.f03 +++ b/test/serial/d_matgen.f03 @@ -371,7 +371,7 @@ contains end if !!$ call a_n%print(19) t1 = psb_wtime() - call a_n%cscnv(info,mold=acsr) + call a_n%cscnv(info,mold=acxx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -383,6 +383,10 @@ contains call psb_barrier(ictxt) ttot = psb_wtime() - t0 + if(iam == psb_root_) write(psb_out_unit,& + & '("The matrix has been generated and is currently in ",a3," format.")')& + & a_n%get_fmt() + !!$ call a_n%print(20) anorm = a_n%csnmi() write(psb_err_unit,*) 'Nrm infinity ',anorm diff --git a/test/serial/psb_d_cxx_impl.f03 b/test/serial/psb_d_cxx_impl.f03 index 296086c6..275db6f0 100644 --- a/test/serial/psb_d_cxx_impl.f03 +++ b/test/serial/psb_d_cxx_impl.f03 @@ -12,10 +12,9 @@ ! ! == =================================== -subroutine d_cxx_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_error_mod - use psb_string_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cxx_csmv_impl +subroutine psb_d_cxx_csmv(alpha,a,x,beta,y,info,trans) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_csmv implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -57,7 +56,20 @@ subroutine d_cxx_csmv_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - call d_cxx_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,& + if (size(x,1) d_cxx_csmm_impl +subroutine psb_d_cxx_csmm(alpha,a,x,beta,y,info,trans) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_csmm implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -340,6 +351,18 @@ subroutine d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) d_cxx_cssv_impl +subroutine psb_d_cxx_cssv(alpha,a,x,beta,y,info,trans) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_cssv implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -799,14 +821,13 @@ contains end if end subroutine inner_cxxsv -end subroutine d_cxx_cssv_impl +end subroutine psb_d_cxx_cssv -subroutine d_cxx_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_error_mod - use psb_string_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cxx_cssm_impl +subroutine psb_d_cxx_cssm(alpha,a,x,beta,y,info,trans) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_cssm implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -1017,56 +1038,541 @@ contains end if end subroutine inner_cxxsm -end subroutine d_cxx_cssm_impl +end subroutine psb_d_cxx_cssm + +function psb_d_cxx_csnmi(a) result(res) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_csnmi + implicit none + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc + real(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + + 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_d_cxx_csnmi + + +function psb_d_cxx_csnm1(a) result(res) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_csnm1 + + implicit none + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_cxx_csnm1' + logical, parameter :: debug=.false. + + + res = -done + nnz = a%get_nzeros() + m = a%get_nrows() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + vt(:) = dzero + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + vt(k) = vt(k) + abs(a%val(k)) + end do + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_d_cxx_csnm1 + +subroutine psb_d_cxx_rowsum(d,a) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_rowsum + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + 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) + (a%val(j)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_rowsum + +subroutine psb_d_cxx_arwsum(d,a) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_arwsum + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + 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 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_arwsum + +subroutine psb_d_cxx_colsum(d,a) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_colsum + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + 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) + (a%val(k)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_colsum + +subroutine psb_d_cxx_aclsum(d,a) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_aclsum + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + 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(k)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_aclsum + + +subroutine psb_d_cxx_get_diag(a,d,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_get_diag + implicit none + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + 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 + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_get_diag + + +subroutine psb_d_cxx_scal(d,a,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_scal + implicit none + class(psb_d_cxx_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + 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 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_scal + + +subroutine psb_d_cxx_scals(d,a,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_scals + implicit none + class(psb_d_cxx_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_d_cxx_reallocate_nz(nz,a) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_d_cxx_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='d_cxx_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_reallocate_nz + +subroutine psb_d_cxx_mold(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_mold + implicit none + class(psb_d_cxx_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_d_cxx_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cxx_mold -function d_cxx_csnmi_impl(a) result(res) - use psb_error_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cxx_csnmi_impl +subroutine psb_d_cxx_allocate_mnnz(m,n,a,nz) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_allocate_mnnz implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer :: i,j,k,m,n, nr, ir, jc, nc - real(psb_dpk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csnmi' + integer, intent(in) :: m,n + class(psb_d_cxx_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + 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_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif - res = dzero - - 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 + 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_) + end if -end function d_cxx_csnmi_impl + call psb_erractionrestore(err_act) + return -! == =================================== -! -! -! -! Data management -! -! -! -! -! -! == =================================== +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_allocate_mnnz -subroutine d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_d_cxx_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cxx_csgetptn_impl + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_csgetptn implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a @@ -1161,10 +1667,6 @@ contains subroutine cxx_getptn(imin,imax,jmin,jmax,a,nz,ia,ja,nzin,append,info,& & iren) - use psb_const_mod - use psb_error_mod - use psb_realloc_mod - use psb_sort_mod implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a @@ -1231,17 +1733,13 @@ contains end subroutine cxx_getptn -end subroutine d_cxx_csgetptn_impl +end subroutine psb_d_cxx_csgetptn -subroutine d_cxx_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_d_cxx_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cxx_csgetrow_impl + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_csgetrow implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a @@ -1338,10 +1836,6 @@ contains subroutine cxx_getrow(imin,imax,jmin,jmax,a,nz,ia,ja,val,nzin,append,info,& & iren) - use psb_const_mod - use psb_error_mod - use psb_realloc_mod - use psb_sort_mod implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a @@ -1412,14 +1906,70 @@ contains end subroutine cxx_getrow -end subroutine d_cxx_csgetrow_impl +end subroutine psb_d_cxx_csgetrow + +subroutine psb_d_cxx_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_csgetblk + implicit none + + class(psb_d_cxx_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_csgetblk -subroutine d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cxx_csput_impl + +subroutine psb_d_cxx_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_csput implicit none class(psb_d_cxx_sparse_mat), intent(inout) :: a @@ -1434,7 +1984,38 @@ subroutine d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1442,9 +2023,9 @@ subroutine d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = psb_err_invalid_mat_state_ else if (a%is_upd()) then - call d_cxx_srch_upd(nz,ia,ja,val,a,& + call psb_d_cxx_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= psb_success_) then info = psb_err_invalid_mat_state_ @@ -1474,13 +2055,9 @@ subroutine d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine d_cxx_srch_upd(nz,ia,ja,val,a,& + subroutine psb_d_cxx_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_sort_mod implicit none class(psb_d_cxx_sparse_mat), intent(inout) :: a @@ -1667,17 +2244,178 @@ contains end if - end subroutine d_cxx_srch_upd + end subroutine psb_d_cxx_srch_upd + +end subroutine psb_d_cxx_csput + + +subroutine psb_d_cxx_reinit(a,clear) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_reinit + implicit none + + class(psb_d_cxx_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_reinit + +subroutine psb_d_cxx_trim(a) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_trim + implicit none + class(psb_d_cxx_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + 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_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cxx_trim + +subroutine psb_d_cxx_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_print + implicit none + + integer, intent(in) :: iout + class(psb_d_cxx_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='d_cxx_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif -end subroutine d_cxx_csput_impl + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + 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,frmtv) 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,frmtv) 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,frmtv) 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,frmtv) (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,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif +end subroutine psb_d_cxx_print -subroutine d_cp_cxx_from_coo_impl(a,b,info) - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_from_coo_impl +subroutine psb_d_cp_cxx_from_coo(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cp_cxx_from_coo implicit none class(psb_d_cxx_sparse_mat), intent(inout) :: a @@ -1690,22 +2428,21 @@ subroutine d_cp_cxx_from_coo_impl(a,b,info) logical :: rwshr_ Integer :: nza, nr, i,j,irw, idl,err_act, nc Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit + integer :: debug_level, debug_unit character(len=20) :: name - info = psb_success_ - ! This is to have fix_coo called behind the scenes - call tmp%cp_from_coo(b,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) -end subroutine d_cp_cxx_from_coo_impl +end subroutine psb_d_cp_cxx_from_coo -subroutine d_cp_cxx_to_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_to_coo_impl +subroutine psb_d_cp_cxx_to_coo(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cp_cxx_to_coo implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a @@ -1740,14 +2477,12 @@ subroutine d_cp_cxx_to_coo_impl(a,b,info) call b%fix(info) -end subroutine d_cp_cxx_to_coo_impl +end subroutine psb_d_cp_cxx_to_coo -subroutine d_mv_cxx_to_coo_impl(a,b,info) - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_mv_cxx_to_coo_impl +subroutine psb_d_mv_cxx_to_coo(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_mv_cxx_to_coo implicit none class(psb_d_cxx_sparse_mat), intent(inout) :: a @@ -1783,15 +2518,13 @@ subroutine d_mv_cxx_to_coo_impl(a,b,info) call b%fix(info) -end subroutine d_mv_cxx_to_coo_impl +end subroutine psb_d_mv_cxx_to_coo -subroutine d_mv_cxx_from_coo_impl(a,b,info) - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_mv_cxx_from_coo_impl +subroutine psb_d_mv_cxx_from_coo(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_mv_cxx_from_coo implicit none class(psb_d_cxx_sparse_mat), intent(inout) :: a @@ -1810,11 +2543,9 @@ subroutine d_mv_cxx_from_coo_impl(a,b,info) call b%fix(info) if (info /= psb_success_) return - nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -1822,8 +2553,9 @@ subroutine d_mv_cxx_from_coo_impl(a,b,info) 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() - + if (info /= psb_success_) return if (nza <= 0) then a%irp(:) = 1 else @@ -1874,14 +2606,12 @@ subroutine d_mv_cxx_from_coo_impl(a,b,info) endif -end subroutine d_mv_cxx_from_coo_impl +end subroutine psb_d_mv_cxx_from_coo -subroutine d_mv_cxx_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_mv_cxx_to_fmt_impl +subroutine psb_d_mv_cxx_to_fmt(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_mv_cxx_to_fmt implicit none class(psb_d_cxx_sparse_mat), intent(inout) :: a @@ -1910,22 +2640,20 @@ subroutine d_mv_cxx_to_fmt_impl(a,b,info) call a%free() class default - call tmp%mv_from_fmt(a,info) + call a%mv_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select -end subroutine d_mv_cxx_to_fmt_impl +end subroutine psb_d_mv_cxx_to_fmt -subroutine d_cp_cxx_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_to_fmt_impl +subroutine psb_d_cp_cxx_to_fmt(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cp_cxx_to_fmt implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1945,23 +2673,21 @@ subroutine d_cp_cxx_to_fmt_impl(a,b,info) type is (psb_d_cxx_sparse_mat) call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) - b%irp = a%irp - b%ja = a%ja - b%val = a%val + call psb_safe_cpy( a%irp, b%irp , info) + call psb_safe_cpy( a%ja , b%ja , info) + call psb_safe_cpy( a%val, b%val , info) class default - call tmp%cp_from_fmt(a,info) + call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select -end subroutine d_cp_cxx_to_fmt_impl +end subroutine psb_d_cp_cxx_to_fmt -subroutine d_mv_cxx_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_mv_cxx_from_fmt_impl +subroutine psb_d_mv_cxx_from_fmt(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_mv_cxx_from_fmt implicit none class(psb_d_cxx_sparse_mat), intent(inout) :: a @@ -1990,19 +2716,17 @@ subroutine d_mv_cxx_from_fmt_impl(a,b,info) call b%free() class default - call tmp%mv_from_fmt(b,info) + call b%mv_to_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select -end subroutine d_mv_cxx_from_fmt_impl +end subroutine psb_d_mv_cxx_from_fmt -subroutine d_cp_cxx_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod - use psb_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_from_fmt_impl +subroutine psb_d_cp_cxx_from_fmt(a,b,info) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cp_cxx_from_fmt implicit none class(psb_d_cxx_sparse_mat), intent(inout) :: a @@ -2025,13 +2749,90 @@ subroutine d_cp_cxx_from_fmt_impl(a,b,info) type is (psb_d_cxx_sparse_mat) call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) - a%irp = b%irp - a%ja = b%ja - a%val = b%val + call psb_safe_cpy( b%irp, a%irp , info) + call psb_safe_cpy( b%ja , a%ja , info) + call psb_safe_cpy( b%val, a%val , info) class default - call tmp%cp_from_fmt(b,info) + call b%cp_to_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select -end subroutine d_cp_cxx_from_fmt_impl +end subroutine psb_d_cp_cxx_from_fmt + + +subroutine psb_d_cxx_cp_from(a,b) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_cp_from + implicit none + + class(psb_d_cxx_sparse_mat), intent(inout) :: a + type(psb_d_cxx_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cxx_cp_from + +subroutine psb_d_cxx_mv_from(a,b) + use psb_sparse_mod + use psb_d_cxx_mat_mod, psb_protect_name => psb_d_cxx_mv_from + implicit none + + class(psb_d_cxx_sparse_mat), intent(inout) :: a + type(psb_d_cxx_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_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 psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cxx_mv_from + diff --git a/test/serial/psb_d_cxx_mat_mod.f03 b/test/serial/psb_d_cxx_mat_mod.f03 index 1338998e..c2b35fbb 100644 --- a/test/serial/psb_d_cxx_mat_mod.f03 +++ b/test/serial/psb_d_cxx_mat_mod.f03 @@ -8,163 +8,210 @@ module psb_d_cxx_mat_mod real(psb_dpk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => d_cxx_get_nzeros - procedure, pass(a) :: get_fmt => d_cxx_get_fmt - procedure, pass(a) :: get_diag => d_cxx_get_diag - procedure, pass(a) :: d_base_csmm => d_cxx_csmm - procedure, pass(a) :: d_base_csmv => d_cxx_csmv - procedure, pass(a) :: d_base_cssm => d_cxx_cssm - procedure, pass(a) :: d_base_cssv => d_cxx_cssv - procedure, pass(a) :: d_scals => d_cxx_scals - procedure, pass(a) :: d_scal => d_cxx_scal - procedure, pass(a) :: csnmi => d_cxx_csnmi - procedure, pass(a) :: reallocate_nz => d_cxx_reallocate_nz - procedure, pass(a) :: csput => d_cxx_csput - procedure, pass(a) :: allocate_mnnz => d_cxx_allocate_mnnz - procedure, pass(a) :: cp_to_coo => d_cp_cxx_to_coo - procedure, pass(a) :: cp_from_coo => d_cp_cxx_from_coo - procedure, pass(a) :: cp_to_fmt => d_cp_cxx_to_fmt - procedure, pass(a) :: cp_from_fmt => d_cp_cxx_from_fmt - procedure, pass(a) :: mv_to_coo => d_mv_cxx_to_coo - procedure, pass(a) :: mv_from_coo => d_mv_cxx_from_coo - procedure, pass(a) :: mv_to_fmt => d_mv_cxx_to_fmt - procedure, pass(a) :: mv_from_fmt => d_mv_cxx_from_fmt - procedure, pass(a) :: csgetptn => d_cxx_csgetptn - procedure, pass(a) :: d_csgetrow => d_cxx_csgetrow - procedure, pass(a) :: get_nz_row => d_cxx_get_nz_row - procedure, pass(a) :: get_size => d_cxx_get_size - procedure, pass(a) :: free => d_cxx_free - procedure, pass(a) :: trim => d_cxx_trim - procedure, pass(a) :: print => d_cxx_print - procedure, pass(a) :: sizeof => d_cxx_sizeof - procedure, pass(a) :: reinit => d_cxx_reinit - procedure, pass(a) :: d_cxx_cp_from - generic, public :: cp_from => d_cxx_cp_from - procedure, pass(a) :: d_cxx_mv_from - generic, public :: mv_from => d_cxx_mv_from + procedure, pass(a) :: get_size => d_cxx_get_size + procedure, pass(a) :: get_nzeros => d_cxx_get_nzeros + procedure, pass(a) :: get_fmt => d_cxx_get_fmt + procedure, pass(a) :: sizeof => d_cxx_sizeof + procedure, pass(a) :: d_csmm => psb_d_cxx_csmm + procedure, pass(a) :: d_csmv => psb_d_cxx_csmv + procedure, pass(a) :: d_inner_cssm => psb_d_cxx_cssm + procedure, pass(a) :: d_inner_cssv => psb_d_cxx_cssv + procedure, pass(a) :: d_scals => psb_d_cxx_scals + procedure, pass(a) :: d_scal => psb_d_cxx_scal + procedure, pass(a) :: csnmi => psb_d_cxx_csnmi + procedure, pass(a) :: csnm1 => psb_d_cxx_csnm1 + procedure, pass(a) :: rowsum => psb_d_cxx_rowsum + procedure, pass(a) :: arwsum => psb_d_cxx_arwsum + procedure, pass(a) :: colsum => psb_d_cxx_colsum + procedure, pass(a) :: aclsum => psb_d_cxx_aclsum + procedure, pass(a) :: reallocate_nz => psb_d_cxx_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_d_cxx_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_d_cp_cxx_to_coo + procedure, pass(a) :: cp_from_coo => psb_d_cp_cxx_from_coo + procedure, pass(a) :: cp_to_fmt => psb_d_cp_cxx_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_d_cp_cxx_from_fmt + procedure, pass(a) :: mv_to_coo => psb_d_mv_cxx_to_coo + procedure, pass(a) :: mv_from_coo => psb_d_mv_cxx_from_coo + procedure, pass(a) :: mv_to_fmt => psb_d_mv_cxx_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_d_mv_cxx_from_fmt + procedure, pass(a) :: csput => psb_d_cxx_csput + procedure, pass(a) :: get_diag => psb_d_cxx_get_diag + procedure, pass(a) :: csgetptn => psb_d_cxx_csgetptn + procedure, pass(a) :: d_csgetrow => psb_d_cxx_csgetrow + procedure, pass(a) :: get_nz_row => d_cxx_get_nz_row + procedure, pass(a) :: reinit => psb_d_cxx_reinit + procedure, pass(a) :: trim => psb_d_cxx_trim + procedure, pass(a) :: print => psb_d_cxx_print + procedure, pass(a) :: free => d_cxx_free + procedure, pass(a) :: mold => psb_d_cxx_mold + procedure, pass(a) :: psb_d_cxx_cp_from + generic, public :: cp_from => psb_d_cxx_cp_from + procedure, pass(a) :: psb_d_cxx_mv_from + generic, public :: mv_from => psb_d_cxx_mv_from end type psb_d_cxx_sparse_mat - private :: d_cxx_get_nzeros, d_cxx_csmm, d_cxx_csmv, d_cxx_cssm, d_cxx_cssv, & - & d_cxx_csput, d_cxx_reallocate_nz, d_cxx_allocate_mnnz, & - & d_cxx_free, d_cxx_print, d_cxx_get_fmt, d_cxx_csnmi, get_diag, & - & d_cp_cxx_to_coo, d_cp_cxx_from_coo, & - & d_mv_cxx_to_coo, d_mv_cxx_from_coo, & - & d_cp_cxx_to_fmt, d_cp_cxx_from_fmt, & - & d_mv_cxx_to_fmt, d_mv_cxx_from_fmt, & - & d_cxx_scals, d_cxx_scal, d_cxx_trim, d_cxx_csgetrow, d_cxx_get_size, & - & d_cxx_sizeof, d_cxx_csgetptn, d_cxx_get_nz_row, d_cxx_reinit + private :: d_cxx_get_nzeros, d_cxx_free, d_cxx_get_fmt, & + & d_cxx_get_size, d_cxx_sizeof, d_cxx_get_nz_row - - interface - subroutine d_cp_cxx_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + interface + subroutine psb_d_cxx_reallocate_nz(nz,a) import :: psb_d_cxx_sparse_mat - class(psb_d_cxx_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine d_cp_cxx_to_fmt_impl + integer, intent(in) :: nz + class(psb_d_cxx_sparse_mat), intent(inout) :: a + end subroutine psb_d_cxx_reallocate_nz end interface - + interface - subroutine d_cp_cxx_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + subroutine psb_d_cxx_reinit(a,clear) + import :: psb_d_cxx_sparse_mat + class(psb_d_cxx_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_d_cxx_reinit + end interface + + interface + subroutine psb_d_cxx_trim(a) import :: psb_d_cxx_sparse_mat class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine d_cp_cxx_from_fmt_impl + end subroutine psb_d_cxx_trim end interface - - + interface - subroutine d_cp_cxx_to_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + subroutine psb_d_cxx_mold(a,b,info) + import :: psb_d_cxx_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ + class(psb_d_cxx_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + end subroutine psb_d_cxx_mold + end interface + + interface + subroutine psb_d_cxx_allocate_mnnz(m,n,a,nz) import :: psb_d_cxx_sparse_mat + integer, intent(in) :: m,n + class(psb_d_cxx_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_d_cxx_allocate_mnnz + end interface + + interface + subroutine psb_d_cxx_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import :: psb_d_cxx_sparse_mat + integer, intent(in) :: iout + class(psb_d_cxx_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_d_cxx_print + end interface + + interface + subroutine psb_d_cp_cxx_to_coo(a,b,info) + import :: psb_d_coo_sparse_mat, psb_d_cxx_sparse_mat class(psb_d_cxx_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_cp_cxx_to_coo_impl + end subroutine psb_d_cp_cxx_to_coo end interface - + interface - subroutine d_cp_cxx_from_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import :: psb_d_cxx_sparse_mat + subroutine psb_d_cp_cxx_from_coo(a,b,info) + import :: psb_d_cxx_sparse_mat, psb_d_coo_sparse_mat class(psb_d_cxx_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine d_cp_cxx_from_coo_impl + end subroutine psb_d_cp_cxx_from_coo end interface - + interface - subroutine d_mv_cxx_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import :: psb_d_cxx_sparse_mat - class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine d_mv_cxx_to_fmt_impl + subroutine psb_d_cp_cxx_to_fmt(a,b,info) + import :: psb_d_cxx_sparse_mat, psb_d_base_sparse_mat + class(psb_d_cxx_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_cp_cxx_to_fmt end interface - + interface - subroutine d_mv_cxx_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import :: psb_d_cxx_sparse_mat - class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine d_mv_cxx_from_fmt_impl + subroutine psb_d_cp_cxx_from_fmt(a,b,info) + import :: psb_d_cxx_sparse_mat, psb_d_base_sparse_mat + class(psb_d_cxx_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_d_cp_cxx_from_fmt end interface - - + interface - subroutine d_mv_cxx_to_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import :: psb_d_cxx_sparse_mat + subroutine psb_d_mv_cxx_to_coo(a,b,info) + import :: psb_d_cxx_sparse_mat, psb_d_coo_sparse_mat class(psb_d_cxx_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_cxx_to_coo_impl + end subroutine psb_d_mv_cxx_to_coo end interface - + interface - subroutine d_mv_cxx_from_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import :: psb_d_cxx_sparse_mat + subroutine psb_d_mv_cxx_from_coo(a,b,info) + import :: psb_d_cxx_sparse_mat, psb_d_coo_sparse_mat class(psb_d_cxx_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_cxx_from_coo_impl + end subroutine psb_d_mv_cxx_from_coo end interface - + interface - subroutine d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import :: psb_d_cxx_sparse_mat + subroutine psb_d_mv_cxx_to_fmt(a,b,info) + import :: psb_d_cxx_sparse_mat, psb_d_base_sparse_mat + class(psb_d_cxx_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_mv_cxx_to_fmt + end interface + + interface + subroutine psb_d_mv_cxx_from_fmt(a,b,info) + import :: psb_d_cxx_sparse_mat, psb_d_base_sparse_mat + class(psb_d_cxx_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_mv_cxx_from_fmt + end interface + + interface + subroutine psb_d_cxx_cp_from(a,b) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(inout) :: a + type(psb_d_cxx_sparse_mat), intent(in) :: b + end subroutine psb_d_cxx_cp_from + end interface + + interface + subroutine psb_d_cxx_mv_from(a,b) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(inout) :: a + type(psb_d_cxx_sparse_mat), intent(inout) :: b + end subroutine psb_d_cxx_mv_from + end interface + + + interface + subroutine psb_d_cxx_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_d_cxx_sparse_mat, psb_dpk_ class(psb_d_cxx_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine d_cxx_csput_impl + end subroutine psb_d_cxx_csput end interface - + interface - subroutine d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_d_cxx_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import :: psb_d_cxx_sparse_mat - implicit none - + import :: psb_d_cxx_sparse_mat, psb_dpk_ class(psb_d_cxx_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -174,16 +221,13 @@ module psb_d_cxx_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine d_cxx_csgetptn_impl + end subroutine psb_d_cxx_csgetptn end interface - + interface - subroutine d_cxx_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_d_cxx_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import :: psb_d_cxx_sparse_mat - implicit none - + import :: psb_d_cxx_sparse_mat, psb_dpk_ class(psb_d_cxx_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -194,58 +238,136 @@ module psb_d_cxx_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine d_cxx_csgetrow_impl + end subroutine psb_d_cxx_csgetrow end interface - interface d_cxx_cssm_impl - subroutine d_cxx_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import :: psb_d_cxx_sparse_mat + interface + subroutine psb_d_cxx_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_d_cxx_sparse_mat, psb_dpk_, psb_d_coo_sparse_mat + class(psb_d_cxx_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_cxx_csgetblk + end interface + + interface + subroutine psb_d_cxx_cssv(alpha,a,x,beta,y,info,trans) + import :: psb_d_cxx_sparse_mat, psb_dpk_ class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_cxx_cssv_impl - subroutine d_cxx_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import :: psb_d_cxx_sparse_mat + end subroutine psb_d_cxx_cssv + subroutine psb_d_cxx_cssm(alpha,a,x,beta,y,info,trans) + import :: psb_d_cxx_sparse_mat, psb_dpk_ class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_cxx_cssm_impl + end subroutine psb_d_cxx_cssm end interface - - interface d_cxx_csmm_impl - subroutine d_cxx_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import :: psb_d_cxx_sparse_mat + + interface + subroutine psb_d_cxx_csmv(alpha,a,x,beta,y,info,trans) + import :: psb_d_cxx_sparse_mat, psb_dpk_ class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_cxx_csmv_impl - subroutine d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import :: psb_d_cxx_sparse_mat + end subroutine psb_d_cxx_csmv + subroutine psb_d_cxx_csmm(alpha,a,x,beta,y,info,trans) + import :: psb_d_cxx_sparse_mat, psb_dpk_ class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_cxx_csmm_impl + end subroutine psb_d_cxx_csmm end interface - - interface d_cxx_csnmi_impl - function d_cxx_csnmi_impl(a) result(res) - use psb_const_mod - import :: psb_d_cxx_sparse_mat + + + interface + function psb_d_cxx_csnmi(a) result(res) + import :: psb_d_cxx_sparse_mat, psb_dpk_ class(psb_d_cxx_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - end function d_cxx_csnmi_impl + end function psb_d_cxx_csnmi + end interface + + interface + function psb_d_cxx_csnm1(a) result(res) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_cxx_csnm1 + end interface + + interface + subroutine psb_d_cxx_rowsum(d,a) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_cxx_rowsum + end interface + + interface + subroutine psb_d_cxx_arwsum(d,a) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_cxx_arwsum + end interface + + interface + subroutine psb_d_cxx_colsum(d,a) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_cxx_colsum + end interface + + interface + subroutine psb_d_cxx_aclsum(d,a) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_cxx_aclsum + end interface + + interface + subroutine psb_d_cxx_get_diag(a,d,info) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_cxx_get_diag + end interface + + interface + subroutine psb_d_cxx_scal(d,a,info) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_cxx_scal + end interface + + interface + subroutine psb_d_cxx_scals(d,a,info) + import :: psb_d_cxx_sparse_mat, psb_dpk_ + class(psb_d_cxx_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_d_cxx_scals end interface @@ -317,7 +439,7 @@ contains function d_cxx_get_nz_row(idx,a) result(res) - use psb_const_mod + implicit none class(psb_d_cxx_sparse_mat), intent(in) :: a @@ -346,341 +468,6 @@ contains ! ! == =================================== - - subroutine d_cxx_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_d_cxx_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='d_cxx_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ja,info) - if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info == psb_success_) call psb_realloc(& - & max(nz,a%get_nrows()+1,a%get_ncols()+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 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_reallocate_nz - - subroutine d_cxx_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='d_cxx_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = psb_success_ - - if (nz <= 0) then - info = psb_err_iarg_neg_ - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_cxx_csput - - subroutine d_cxx_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_cxx_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - call d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_csgetptn - - - subroutine d_cxx_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_cxx_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - call d_cxx_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_csgetrow - - - subroutine d_cxx_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_cxx_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_csgetblk - - - subroutine d_cxx_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_cxx_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - nzin = 0 - 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 = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_csclip - - subroutine d_cxx_free(a) implicit none @@ -697,906 +484,5 @@ contains end subroutine d_cxx_free - subroutine d_cxx_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_d_cxx_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = dzero - call a%set_upd() - else - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_reinit - - - subroutine d_cxx_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, m - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - m = a%get_nrows() - nz = a%get_nzeros() - 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_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_trim - - - subroutine d_cp_cxx_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call d_cp_cxx_to_coo_impl(a,b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_cxx_to_coo - - subroutine d_cp_cxx_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call d_cp_cxx_from_coo_impl(a,b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_cxx_from_coo - - - subroutine d_cp_cxx_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call d_cp_cxx_to_fmt_impl(a,b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_cxx_to_fmt - - subroutine d_cp_cxx_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call d_cp_cxx_from_fmt_impl(a,b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_cxx_from_fmt - - - subroutine d_mv_cxx_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call d_mv_cxx_to_coo_impl(a,b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_cxx_to_coo - - subroutine d_mv_cxx_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call d_mv_cxx_from_coo_impl(a,b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_cxx_from_coo - - - subroutine d_mv_cxx_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call d_mv_cxx_to_fmt_impl(a,b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_cxx_to_fmt - - subroutine d_mv_cxx_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call d_mv_cxx_from_fmt_impl(a,b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_cxx_from_fmt - - - subroutine d_cxx_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_d_cxx_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - 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_ - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - 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.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_allocate_mnnz - - - subroutine d_cxx_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_d_cxx_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='d_cxx_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - 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,frmtv) 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,frmtv) 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,frmtv) 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,frmtv) (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,frmtv) (i),(a%ja(j)),a%val(j) - end do - enddo - endif - endif - - end subroutine d_cxx_print - - - subroutine d_cxx_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_cxx_sparse_mat), intent(out) :: a - type(psb_d_cxx_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) - a%irp = b%irp - a%ja = b%ja - a%val = b%val - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cxx_cp_from - - subroutine d_cxx_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_cxx_sparse_mat), intent(out) :: a - type(psb_d_cxx_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_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 psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cxx_mv_from - - - - ! == =================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - ! == =================================== - - - subroutine d_cxx_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='d_cxx_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - - call d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_csmv - - subroutine d_cxx_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_cxx_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_csmm - - - subroutine d_cxx_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_cxx_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call d_cxx_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine d_cxx_cssv - - - - subroutine d_cxx_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_cxx_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call d_cxx_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_cssm - - function d_cxx_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = d_cxx_csnmi_impl(a) - - return - - end function d_cxx_csnmi - - subroutine d_cxx_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - 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 - do i=mnm+1,size(d) - d(i) = dzero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_get_diag - - - subroutine d_cxx_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - 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 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_scal - - - subroutine d_cxx_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_cxx_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cxx_scals - - end module psb_d_cxx_mat_mod