diff --git a/base/modules/psb_d_base_mat_mod.f90 b/base/modules/psb_d_base_mat_mod.f90 index f03f9127..2d88c056 100644 --- a/base/modules/psb_d_base_mat_mod.f90 +++ b/base/modules/psb_d_base_mat_mod.f90 @@ -57,7 +57,9 @@ module psb_d_base_mat_mod ! ! Data management methods: defined here, but (mostly) not implemented. ! - procedure, pass(a) :: csput => psb_d_base_csput + procedure, pass(a) :: csput_a => psb_d_base_csput_a + procedure, pass(a) :: csput_v => psb_d_base_csput_v + generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_d_base_csgetrow procedure, pass(a) :: csgetblk => psb_d_base_csgetblk procedure, pass(a) :: get_diag => psb_d_base_get_diag @@ -156,7 +158,7 @@ module psb_d_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_d_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_d_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_d_mv_coo_from_fmt - procedure, pass(a) :: csput => psb_d_coo_csput + procedure, pass(a) :: csput_a => psb_d_coo_csput_a procedure, pass(a) :: get_diag => psb_d_coo_get_diag procedure, pass(a) :: csgetrow => psb_d_coo_csgetrow procedure, pass(a) :: csgetptn => psb_d_coo_csgetptn @@ -255,14 +257,27 @@ module psb_d_base_mat_mod !! ! interface - subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_d_base_csput + end subroutine psb_d_base_csput_a + end interface + + interface + subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_, psb_d_base_vect_type,& + & psb_i_base_vect_type + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_vect_type), intent(inout) :: val + class(psb_i_base_vect_type), intent(inout) :: ia, ja + integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_d_base_csput_v end interface ! @@ -1469,7 +1484,7 @@ module psb_d_base_mat_mod !! ! interface - subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -1477,7 +1492,7 @@ module psb_d_base_mat_mod & imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_d_coo_csput + end subroutine psb_d_coo_csput_a end interface !> diff --git a/base/modules/psb_d_csc_mat_mod.f90 b/base/modules/psb_d_csc_mat_mod.f90 index e64e787a..987c6530 100644 --- a/base/modules/psb_d_csc_mat_mod.f90 +++ b/base/modules/psb_d_csc_mat_mod.f90 @@ -88,7 +88,7 @@ module psb_d_csc_mat_mod procedure, pass(a) :: mv_from_coo => psb_d_mv_csc_from_coo procedure, pass(a) :: mv_to_fmt => psb_d_mv_csc_to_fmt procedure, pass(a) :: mv_from_fmt => psb_d_mv_csc_from_fmt - procedure, pass(a) :: csput => psb_d_csc_csput + procedure, pass(a) :: csput_a => psb_d_csc_csput_a procedure, pass(a) :: get_diag => psb_d_csc_get_diag procedure, pass(a) :: csgetptn => psb_d_csc_csgetptn procedure, pass(a) :: csgetrow => psb_d_csc_csgetrow @@ -279,9 +279,9 @@ module psb_d_csc_mat_mod !> \memberof psb_d_csc_sparse_mat - !! \see psb_d_base_mat_mod::psb_d_base_csput + !! \see psb_d_base_mat_mod::psb_d_base_csput_a interface - subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -289,7 +289,7 @@ module psb_d_csc_mat_mod & imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_d_csc_csput + end subroutine psb_d_csc_csput_a end interface !> \memberof psb_d_csc_sparse_mat diff --git a/base/modules/psb_d_csr_mat_mod.f90 b/base/modules/psb_d_csr_mat_mod.f90 index 25fa9c39..bfe3e458 100644 --- a/base/modules/psb_d_csr_mat_mod.f90 +++ b/base/modules/psb_d_csr_mat_mod.f90 @@ -89,7 +89,7 @@ module psb_d_csr_mat_mod procedure, pass(a) :: mv_from_coo => psb_d_mv_csr_from_coo procedure, pass(a) :: mv_to_fmt => psb_d_mv_csr_to_fmt procedure, pass(a) :: mv_from_fmt => psb_d_mv_csr_from_fmt - procedure, pass(a) :: csput => psb_d_csr_csput + procedure, pass(a) :: csput_a => psb_d_csr_csput_a procedure, pass(a) :: get_diag => psb_d_csr_get_diag procedure, pass(a) :: csgetptn => psb_d_csr_csgetptn procedure, pass(a) :: csgetrow => psb_d_csr_csgetrow @@ -282,9 +282,9 @@ module psb_d_csr_mat_mod !> \memberof psb_d_csr_sparse_mat - !! \see psb_d_base_mat_mod::psb_d_base_csput + !! \see psb_d_base_mat_mod::psb_d_base_csput_a interface - subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -292,7 +292,7 @@ module psb_d_csr_mat_mod & imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_d_csr_csput + end subroutine psb_d_csr_csput_a end interface !> \memberof psb_d_csr_sparse_mat diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index e41806b4..7ec570c8 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -327,9 +327,9 @@ subroutine psb_d_base_mv_from_fmt(a,b,info) end subroutine psb_d_base_mv_from_fmt -subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_a implicit none class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -354,7 +354,56 @@ subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) end if return -end subroutine psb_d_base_csput +end subroutine psb_d_base_csput_a + + +subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_v + use psb_d_base_vect_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_vect_type), intent(inout) :: val + class(psb_i_base_vect_type), intent(inout) :: ia, ja + integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act, nzin, nzout + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + 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_base_csput_v + + subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) @@ -456,7 +505,7 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 'd_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' @@ -682,7 +731,7 @@ subroutine psb_d_base_tril(a,b,info,& & b%ia(1:nzout) = b%ia(1:nzout) - imin_ + 1 if (cscale_) & & b%ja(1:nzout) = b%ja(1:nzout) - jmin_ + 1 - + if ((diag_ <= 0).and.(imin_ == jmin_)) then call b%set_triangle(.true.) call b%set_lower(.true.) @@ -792,7 +841,7 @@ subroutine psb_d_base_triu(a,b,info,& & b%ia(1:nzout) = b%ia(1:nzout) - imin_ + 1 if (cscale_) & & b%ja(1:nzout) = b%ja(1:nzout) - jmin_ + 1 - + if ((diag_ >= 0).and.(imin_ == jmin_)) then call b%set_triangle(.true.) call b%set_upper(.true.) @@ -820,7 +869,7 @@ subroutine psb_d_base_clone(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_clone use psb_error_mod implicit none - + class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), allocatable, intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -843,7 +892,7 @@ subroutine psb_d_base_clone(a,b,info) call a%mold(b,info) #endif if (info == psb_success_) call b%cp_from_fmt(a, info) - + end subroutine psb_d_base_clone subroutine psb_d_base_make_nonunit(a) @@ -852,7 +901,7 @@ subroutine psb_d_base_make_nonunit(a) implicit none class(psb_d_base_sparse_mat), intent(inout) :: a type(psb_d_coo_sparse_mat) :: tmp - + integer(psb_ipk_) :: i, j, m, n, nz, mnm, info if (a%is_unit()) then @@ -920,11 +969,11 @@ subroutine psb_d_base_transp_2mat(a,b) info = psb_success_ select type(b) - class is (psb_d_base_sparse_mat) + class is (psb_d_base_sparse_mat) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default + class default info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then @@ -960,11 +1009,11 @@ subroutine psb_d_base_transc_2mat(a,b) info = psb_success_ select type(b) - class is (psb_d_base_sparse_mat) + class is (psb_d_base_sparse_mat) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default + class default info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then @@ -1271,7 +1320,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; + ierr(1) = 9; ierr(2) = nar; call psb_errpush(info,name,i_err=ierr) goto 9999 end if @@ -1407,7 +1456,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; + ierr(1) = 9; ierr(2) = nar; call psb_errpush(info,name,i_err=ierr) goto 9999 end if diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index c4aaedd2..f768927b 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -2573,11 +2573,11 @@ contains end subroutine psb_d_coo_csgetrow -subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod use psb_sort_mod - use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csput + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csput_a implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a @@ -2589,7 +2589,7 @@ subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='d_coo_csput_impl' + character(len=20) :: name='d_coo_csput_a_impl' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit @@ -2953,7 +2953,7 @@ contains end subroutine d_coo_srch_upd -end subroutine psb_d_coo_csput +end subroutine psb_d_coo_csput_a subroutine psb_d_cp_coo_to_coo(a,b,info) diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index e6b2c492..3beea7b8 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -1965,10 +1965,10 @@ end subroutine psb_d_csc_csgetrow -subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput_a implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -1980,7 +1980,7 @@ subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='d_csc_csput' + character(len=20) :: name='d_csc_csput_a' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit @@ -2232,7 +2232,7 @@ contains end subroutine psb_d_csc_srch_upd -end subroutine psb_d_csc_csput +end subroutine psb_d_csc_csput_a diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index ffa7f66a..2c7f07c3 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -2338,10 +2338,10 @@ end subroutine psb_d_csr_csgetblk -subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput_a implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -2353,7 +2353,7 @@ subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='d_csr_csput' + character(len=20) :: name='d_csr_csput_a' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit @@ -2604,7 +2604,7 @@ contains end subroutine psb_d_csr_srch_upd -end subroutine psb_d_csr_csput +end subroutine psb_d_csr_csput_a subroutine psb_d_csr_reinit(a,clear)