From 3337a12e593ba0184969321bc9cefa866c223d68 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 13 Jan 2026 15:26:11 +0100 Subject: [PATCH] Fix multivect handling --- base/modules/serial/psb_c_base_vect_mod.F90 | 413 +++++++++++++++++--- base/modules/serial/psb_c_vect_mod.F90 | 6 +- base/modules/serial/psb_d_base_vect_mod.F90 | 411 ++++++++++++++++--- base/modules/serial/psb_d_vect_mod.F90 | 6 +- base/modules/serial/psb_i_base_vect_mod.F90 | 411 ++++++++++++++++--- base/modules/serial/psb_i_vect_mod.F90 | 6 +- base/modules/serial/psb_l_base_vect_mod.F90 | 413 +++++++++++++++++--- base/modules/serial/psb_l_vect_mod.F90 | 6 +- base/modules/serial/psb_s_base_vect_mod.F90 | 413 +++++++++++++++++--- base/modules/serial/psb_s_vect_mod.F90 | 6 +- base/modules/serial/psb_z_base_vect_mod.F90 | 413 +++++++++++++++++--- base/modules/serial/psb_z_vect_mod.F90 | 6 +- base/modules/tools/psb_c_tools_mod.F90 | 3 +- base/modules/tools/psb_d_tools_mod.F90 | 3 +- base/modules/tools/psb_i_tools_mod.F90 | 3 +- base/modules/tools/psb_l_tools_mod.F90 | 3 +- base/modules/tools/psb_s_tools_mod.F90 | 3 +- base/modules/tools/psb_z_tools_mod.F90 | 3 +- base/tools/psb_callc.f90 | 42 +- base/tools/psb_casb.f90 | 38 +- base/tools/psb_cins.f90 | 2 +- base/tools/psb_dallc.f90 | 42 +- base/tools/psb_dasb.f90 | 38 +- base/tools/psb_dins.f90 | 2 +- base/tools/psb_iallc.f90 | 42 +- base/tools/psb_iasb.f90 | 38 +- base/tools/psb_iins.f90 | 2 +- base/tools/psb_lallc.f90 | 42 +- base/tools/psb_lasb.f90 | 38 +- base/tools/psb_lins.f90 | 2 +- base/tools/psb_sallc.f90 | 42 +- base/tools/psb_sasb.f90 | 38 +- base/tools/psb_sins.f90 | 2 +- base/tools/psb_zallc.f90 | 42 +- base/tools/psb_zasb.f90 | 38 +- base/tools/psb_zins.f90 | 2 +- 36 files changed, 2206 insertions(+), 814 deletions(-) diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index ed1b4597..20ee1ef0 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -397,22 +397,6 @@ contains end subroutine c_base_all - subroutine c_base_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) then - call x%sync() - x%v(:) = czero - call x%set_host() - call x%set_upd() - end if - - end subroutine c_base_reinit - !> Function base_mold: !! \memberof psb_c_base_vect_type !! \brief Mold method: return a variable with the same dynamic type @@ -431,6 +415,22 @@ contains end subroutine c_base_mold + subroutine c_base_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_c_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:) = czero + call x%set_host() + call x%set_upd() + end if + + end subroutine c_base_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -491,7 +491,9 @@ contains end if enddo call x%set_ncfs(k) + else if (x%is_upd()) then + dupl_ = x%get_dupl() if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ @@ -662,7 +664,7 @@ contains ncfs = x%get_ncfs() xvsz = psb_size(x%v) call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = czero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,ncfs @@ -674,7 +676,7 @@ contains end do case(psb_dupl_err_) do i=1,ncfs - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. czero) then call psb_errpush(psb_err_duplicate_coo,'vect-asb') return else @@ -745,7 +747,7 @@ contains & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') if (x%is_bld()) then call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = czero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,x%get_ncfs() @@ -757,7 +759,7 @@ contains end do case(psb_dupl_err_) do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. czero) then call psb_errpush(psb_err_duplicate_coo,'vect_asb') return else @@ -815,8 +817,6 @@ contains call x%set_null() end subroutine c_base_free - - ! !> Function base_free_buffer: !! \memberof psb_c_base_vect_type @@ -2440,6 +2440,18 @@ module psb_c_base_multivect_mod complex(psb_spk_), allocatable :: v(:,:) complex(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -2458,6 +2470,22 @@ module psb_c_base_multivect_mod procedure, pass(x) :: zero => c_base_mlv_zero procedure, pass(x) :: asb => c_base_mlv_asb procedure, pass(x) :: free => c_base_mlv_free + procedure, pass(x) :: reinit => c_base_mlv_reinit + procedure, pass(x) :: set_ncfs => c_base_mlv_set_ncfs + procedure, pass(x) :: get_ncfs => c_base_mlv_get_ncfs + procedure, pass(x) :: set_dupl => c_base_mlv_set_dupl + procedure, pass(x) :: get_dupl => c_base_mlv_get_dupl + procedure, pass(x) :: set_state => c_base_mlv_set_state + procedure, pass(x) :: set_null => c_base_mlv_set_null + procedure, pass(x) :: set_bld => c_base_mlv_set_bld + procedure, pass(x) :: set_upd => c_base_mlv_set_upd + procedure, pass(x) :: set_asb => c_base_mlv_set_asb + procedure, pass(x) :: get_state => c_base_mlv_get_state + procedure, pass(x) :: is_null => c_base_mlv_is_null + procedure, pass(x) :: is_bld => c_base_mlv_is_bld + procedure, pass(x) :: is_upd => c_base_mlv_is_upd + procedure, pass(x) :: is_asb => c_base_mlv_is_asb + procedure, pass(x) :: base_cpy => c_base_mlv_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -2571,7 +2599,8 @@ contains integer(psb_ipk_) :: info this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) end function constructor @@ -2621,12 +2650,21 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine c_base_mlv_bld_n(x,m,n) + subroutine c_base_mlv_bld_n(x,m,n,scratch) use psb_realloc_mod integer(psb_ipk_), intent(in) :: m,n class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(m,n,x%v,info) call x%asb(m,n,info) @@ -2648,6 +2686,10 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if end subroutine c_base_mlv_all @@ -2669,6 +2711,22 @@ contains end subroutine c_base_mlv_mold + subroutine c_base_mlv_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_c_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = czero + call x%set_host() + call x%set_upd() + end if + + end subroutine c_base_mlv_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -2696,57 +2754,123 @@ contains !! \param info return code !! ! - subroutine c_base_mlv_ins(n,irl,val,dupl,x,info) + subroutine c_base_mlv_ins(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: irl(:) complex(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k info = 0 if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ do i = 1, n !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 ! this row belongs to me ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) end if enddo + call x%set_ncfs(k) - case(psb_dupl_add_) + else if (x%is_upd()) then - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if end if + call x%set_host() if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return @@ -2766,6 +2890,7 @@ contains class(psb_c_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=czero + call x%set_host() end subroutine c_base_mlv_zero @@ -2784,19 +2909,73 @@ contains !! ! - subroutine c_base_mlv_asb(m,n, x, info) + subroutine c_base_mlv_asb(m,n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine c_base_mlv_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_c_base_multivect_type), intent(in) :: x + class(psb_c_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine c_base_mlv_cpy + ! ! Size info. @@ -2960,7 +3255,7 @@ contains integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * (2*psb_sizeof_sp)) * x%get_nrows() * x%get_ncols() end function c_base_mlv_sizeof diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index 274bd571..4053492f 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -1887,11 +1887,11 @@ contains end subroutine c_mvect_free - subroutine c_mvect_ins(n,irl,val,x,info) + subroutine c_mvect_ins(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_c_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n,maxr integer(psb_ipk_), intent(in) :: irl(:) complex(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info @@ -1904,7 +1904,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl,val,dupl,info) + call x%v%ins(n,irl,val,dupl,maxr,info) end subroutine c_mvect_ins diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index 71b921cd..907d1034 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -404,22 +404,6 @@ contains end subroutine d_base_all - subroutine d_base_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) then - call x%sync() - x%v(:) = dzero - call x%set_host() - call x%set_upd() - end if - - end subroutine d_base_reinit - !> Function base_mold: !! \memberof psb_d_base_vect_type !! \brief Mold method: return a variable with the same dynamic type @@ -438,6 +422,22 @@ contains end subroutine d_base_mold + subroutine d_base_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_d_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:) = dzero + call x%set_host() + call x%set_upd() + end if + + end subroutine d_base_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -498,7 +498,9 @@ contains end if enddo call x%set_ncfs(k) + else if (x%is_upd()) then + dupl_ = x%get_dupl() if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ @@ -681,7 +683,7 @@ contains end do case(psb_dupl_err_) do i=1,ncfs - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. dzero) then call psb_errpush(psb_err_duplicate_coo,'vect-asb') return else @@ -752,7 +754,7 @@ contains & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') if (x%is_bld()) then call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = dzero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,x%get_ncfs() @@ -764,7 +766,7 @@ contains end do case(psb_dupl_err_) do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. dzero) then call psb_errpush(psb_err_duplicate_coo,'vect_asb') return else @@ -822,8 +824,6 @@ contains call x%set_null() end subroutine d_base_free - - ! !> Function base_free_buffer: !! \memberof psb_d_base_vect_type @@ -2619,6 +2619,18 @@ module psb_d_base_multivect_mod real(psb_dpk_), allocatable :: v(:,:) real(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -2637,6 +2649,22 @@ module psb_d_base_multivect_mod procedure, pass(x) :: zero => d_base_mlv_zero procedure, pass(x) :: asb => d_base_mlv_asb procedure, pass(x) :: free => d_base_mlv_free + procedure, pass(x) :: reinit => d_base_mlv_reinit + procedure, pass(x) :: set_ncfs => d_base_mlv_set_ncfs + procedure, pass(x) :: get_ncfs => d_base_mlv_get_ncfs + procedure, pass(x) :: set_dupl => d_base_mlv_set_dupl + procedure, pass(x) :: get_dupl => d_base_mlv_get_dupl + procedure, pass(x) :: set_state => d_base_mlv_set_state + procedure, pass(x) :: set_null => d_base_mlv_set_null + procedure, pass(x) :: set_bld => d_base_mlv_set_bld + procedure, pass(x) :: set_upd => d_base_mlv_set_upd + procedure, pass(x) :: set_asb => d_base_mlv_set_asb + procedure, pass(x) :: get_state => d_base_mlv_get_state + procedure, pass(x) :: is_null => d_base_mlv_is_null + procedure, pass(x) :: is_bld => d_base_mlv_is_bld + procedure, pass(x) :: is_upd => d_base_mlv_is_upd + procedure, pass(x) :: is_asb => d_base_mlv_is_asb + procedure, pass(x) :: base_cpy => d_base_mlv_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -2750,7 +2778,8 @@ contains integer(psb_ipk_) :: info this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) end function constructor @@ -2800,12 +2829,21 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine d_base_mlv_bld_n(x,m,n) + subroutine d_base_mlv_bld_n(x,m,n,scratch) use psb_realloc_mod integer(psb_ipk_), intent(in) :: m,n class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(m,n,x%v,info) call x%asb(m,n,info) @@ -2827,6 +2865,10 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if end subroutine d_base_mlv_all @@ -2848,6 +2890,22 @@ contains end subroutine d_base_mlv_mold + subroutine d_base_mlv_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_d_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = dzero + call x%set_host() + call x%set_upd() + end if + + end subroutine d_base_mlv_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -2875,57 +2933,123 @@ contains !! \param info return code !! ! - subroutine d_base_mlv_ins(n,irl,val,dupl,x,info) + subroutine d_base_mlv_ins(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: irl(:) real(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k info = 0 if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ do i = 1, n !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 ! this row belongs to me ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) end if enddo + call x%set_ncfs(k) - case(psb_dupl_add_) + else if (x%is_upd()) then - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if end if + call x%set_host() if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return @@ -2945,6 +3069,7 @@ contains class(psb_d_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=dzero + call x%set_host() end subroutine d_base_mlv_zero @@ -2963,19 +3088,73 @@ contains !! ! - subroutine d_base_mlv_asb(m,n, x, info) + subroutine d_base_mlv_asb(m,n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine d_base_mlv_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_d_base_multivect_type), intent(in) :: x + class(psb_d_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine d_base_mlv_cpy + ! ! Size info. @@ -3139,7 +3434,7 @@ contains integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * psb_sizeof_dp) * x%get_nrows() * x%get_ncols() end function d_base_mlv_sizeof diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 4e022653..d2df69ff 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -1966,11 +1966,11 @@ contains end subroutine d_mvect_free - subroutine d_mvect_ins(n,irl,val,x,info) + subroutine d_mvect_ins(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_d_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n,maxr integer(psb_ipk_), intent(in) :: irl(:) real(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info @@ -1983,7 +1983,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl,val,dupl,info) + call x%v%ins(n,irl,val,dupl,maxr,info) end subroutine d_mvect_ins diff --git a/base/modules/serial/psb_i_base_vect_mod.F90 b/base/modules/serial/psb_i_base_vect_mod.F90 index f55815cf..3a096eb3 100644 --- a/base/modules/serial/psb_i_base_vect_mod.F90 +++ b/base/modules/serial/psb_i_base_vect_mod.F90 @@ -330,22 +330,6 @@ contains end subroutine i_base_all - subroutine i_base_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) then - call x%sync() - x%v(:) = izero - call x%set_host() - call x%set_upd() - end if - - end subroutine i_base_reinit - !> Function base_mold: !! \memberof psb_i_base_vect_type !! \brief Mold method: return a variable with the same dynamic type @@ -364,6 +348,22 @@ contains end subroutine i_base_mold + subroutine i_base_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:) = izero + call x%set_host() + call x%set_upd() + end if + + end subroutine i_base_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -424,7 +424,9 @@ contains end if enddo call x%set_ncfs(k) + else if (x%is_upd()) then + dupl_ = x%get_dupl() if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ @@ -595,7 +597,7 @@ contains ncfs = x%get_ncfs() xvsz = psb_size(x%v) call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = izero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,ncfs @@ -607,7 +609,7 @@ contains end do case(psb_dupl_err_) do i=1,ncfs - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. izero) then call psb_errpush(psb_err_duplicate_coo,'vect-asb') return else @@ -678,7 +680,7 @@ contains & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') if (x%is_bld()) then call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = izero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,x%get_ncfs() @@ -690,7 +692,7 @@ contains end do case(psb_dupl_err_) do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. izero) then call psb_errpush(psb_err_duplicate_coo,'vect_asb') return else @@ -748,8 +750,6 @@ contains call x%set_null() end subroutine i_base_free - - ! !> Function base_free_buffer: !! \memberof psb_i_base_vect_type @@ -1398,6 +1398,18 @@ module psb_i_base_multivect_mod integer(psb_ipk_), allocatable :: v(:,:) integer(psb_ipk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -1416,6 +1428,22 @@ module psb_i_base_multivect_mod procedure, pass(x) :: zero => i_base_mlv_zero procedure, pass(x) :: asb => i_base_mlv_asb procedure, pass(x) :: free => i_base_mlv_free + procedure, pass(x) :: reinit => i_base_mlv_reinit + procedure, pass(x) :: set_ncfs => i_base_mlv_set_ncfs + procedure, pass(x) :: get_ncfs => i_base_mlv_get_ncfs + procedure, pass(x) :: set_dupl => i_base_mlv_set_dupl + procedure, pass(x) :: get_dupl => i_base_mlv_get_dupl + procedure, pass(x) :: set_state => i_base_mlv_set_state + procedure, pass(x) :: set_null => i_base_mlv_set_null + procedure, pass(x) :: set_bld => i_base_mlv_set_bld + procedure, pass(x) :: set_upd => i_base_mlv_set_upd + procedure, pass(x) :: set_asb => i_base_mlv_set_asb + procedure, pass(x) :: get_state => i_base_mlv_get_state + procedure, pass(x) :: is_null => i_base_mlv_is_null + procedure, pass(x) :: is_bld => i_base_mlv_is_bld + procedure, pass(x) :: is_upd => i_base_mlv_is_upd + procedure, pass(x) :: is_asb => i_base_mlv_is_asb + procedure, pass(x) :: base_cpy => i_base_mlv_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -1496,7 +1524,8 @@ contains integer(psb_ipk_) :: info this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) end function constructor @@ -1546,12 +1575,21 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i_base_mlv_bld_n(x,m,n) + subroutine i_base_mlv_bld_n(x,m,n,scratch) use psb_realloc_mod integer(psb_ipk_), intent(in) :: m,n class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(m,n,x%v,info) call x%asb(m,n,info) @@ -1573,6 +1611,10 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if end subroutine i_base_mlv_all @@ -1594,6 +1636,22 @@ contains end subroutine i_base_mlv_mold + subroutine i_base_mlv_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = izero + call x%set_host() + call x%set_upd() + end if + + end subroutine i_base_mlv_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -1621,57 +1679,123 @@ contains !! \param info return code !! ! - subroutine i_base_mlv_ins(n,irl,val,dupl,x,info) + subroutine i_base_mlv_ins(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k info = 0 if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ do i = 1, n !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 ! this row belongs to me ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) end if enddo + call x%set_ncfs(k) - case(psb_dupl_add_) + else if (x%is_upd()) then - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if end if + call x%set_host() if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return @@ -1691,6 +1815,7 @@ contains class(psb_i_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=izero + call x%set_host() end subroutine i_base_mlv_zero @@ -1709,19 +1834,73 @@ contains !! ! - subroutine i_base_mlv_asb(m,n, x, info) + subroutine i_base_mlv_asb(m,n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine i_base_mlv_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i_base_multivect_type), intent(in) :: x + class(psb_i_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine i_base_mlv_cpy + ! ! Size info. diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 91230644..adbcaa6a 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -1210,11 +1210,11 @@ contains end subroutine i_mvect_free - subroutine i_mvect_ins(n,irl,val,x,info) + subroutine i_mvect_ins(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n,maxr integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info @@ -1227,7 +1227,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl,val,dupl,info) + call x%v%ins(n,irl,val,dupl,maxr,info) end subroutine i_mvect_ins diff --git a/base/modules/serial/psb_l_base_vect_mod.F90 b/base/modules/serial/psb_l_base_vect_mod.F90 index 6059ff36..4030b0a7 100644 --- a/base/modules/serial/psb_l_base_vect_mod.F90 +++ b/base/modules/serial/psb_l_base_vect_mod.F90 @@ -331,22 +331,6 @@ contains end subroutine l_base_all - subroutine l_base_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) then - call x%sync() - x%v(:) = lzero - call x%set_host() - call x%set_upd() - end if - - end subroutine l_base_reinit - !> Function base_mold: !! \memberof psb_l_base_vect_type !! \brief Mold method: return a variable with the same dynamic type @@ -365,6 +349,22 @@ contains end subroutine l_base_mold + subroutine l_base_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:) = lzero + call x%set_host() + call x%set_upd() + end if + + end subroutine l_base_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -425,7 +425,9 @@ contains end if enddo call x%set_ncfs(k) + else if (x%is_upd()) then + dupl_ = x%get_dupl() if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ @@ -596,7 +598,7 @@ contains ncfs = x%get_ncfs() xvsz = psb_size(x%v) call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = lzero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,ncfs @@ -608,7 +610,7 @@ contains end do case(psb_dupl_err_) do i=1,ncfs - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. lzero) then call psb_errpush(psb_err_duplicate_coo,'vect-asb') return else @@ -679,7 +681,7 @@ contains & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') if (x%is_bld()) then call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = lzero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,x%get_ncfs() @@ -691,7 +693,7 @@ contains end do case(psb_dupl_err_) do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. lzero) then call psb_errpush(psb_err_duplicate_coo,'vect_asb') return else @@ -749,8 +751,6 @@ contains call x%set_null() end subroutine l_base_free - - ! !> Function base_free_buffer: !! \memberof psb_l_base_vect_type @@ -1399,6 +1399,18 @@ module psb_l_base_multivect_mod integer(psb_lpk_), allocatable :: v(:,:) integer(psb_lpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -1417,6 +1429,22 @@ module psb_l_base_multivect_mod procedure, pass(x) :: zero => l_base_mlv_zero procedure, pass(x) :: asb => l_base_mlv_asb procedure, pass(x) :: free => l_base_mlv_free + procedure, pass(x) :: reinit => l_base_mlv_reinit + procedure, pass(x) :: set_ncfs => l_base_mlv_set_ncfs + procedure, pass(x) :: get_ncfs => l_base_mlv_get_ncfs + procedure, pass(x) :: set_dupl => l_base_mlv_set_dupl + procedure, pass(x) :: get_dupl => l_base_mlv_get_dupl + procedure, pass(x) :: set_state => l_base_mlv_set_state + procedure, pass(x) :: set_null => l_base_mlv_set_null + procedure, pass(x) :: set_bld => l_base_mlv_set_bld + procedure, pass(x) :: set_upd => l_base_mlv_set_upd + procedure, pass(x) :: set_asb => l_base_mlv_set_asb + procedure, pass(x) :: get_state => l_base_mlv_get_state + procedure, pass(x) :: is_null => l_base_mlv_is_null + procedure, pass(x) :: is_bld => l_base_mlv_is_bld + procedure, pass(x) :: is_upd => l_base_mlv_is_upd + procedure, pass(x) :: is_asb => l_base_mlv_is_asb + procedure, pass(x) :: base_cpy => l_base_mlv_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -1497,7 +1525,8 @@ contains integer(psb_ipk_) :: info this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) end function constructor @@ -1547,12 +1576,21 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine l_base_mlv_bld_n(x,m,n) + subroutine l_base_mlv_bld_n(x,m,n,scratch) use psb_realloc_mod integer(psb_ipk_), intent(in) :: m,n class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(m,n,x%v,info) call x%asb(m,n,info) @@ -1574,6 +1612,10 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if end subroutine l_base_mlv_all @@ -1595,6 +1637,22 @@ contains end subroutine l_base_mlv_mold + subroutine l_base_mlv_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = lzero + call x%set_host() + call x%set_upd() + end if + + end subroutine l_base_mlv_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -1622,57 +1680,123 @@ contains !! \param info return code !! ! - subroutine l_base_mlv_ins(n,irl,val,dupl,x,info) + subroutine l_base_mlv_ins(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: irl(:) integer(psb_lpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k info = 0 if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ do i = 1, n !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 ! this row belongs to me ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) end if enddo + call x%set_ncfs(k) - case(psb_dupl_add_) + else if (x%is_upd()) then - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if end if + call x%set_host() if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return @@ -1692,6 +1816,7 @@ contains class(psb_l_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=lzero + call x%set_host() end subroutine l_base_mlv_zero @@ -1710,19 +1835,73 @@ contains !! ! - subroutine l_base_mlv_asb(m,n, x, info) + subroutine l_base_mlv_asb(m,n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine l_base_mlv_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(in) :: x + class(psb_l_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine l_base_mlv_cpy + ! ! Size info. @@ -1886,7 +2181,7 @@ contains integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * psb_sizeof_lp) * x%get_nrows() * x%get_ncols() end function l_base_mlv_sizeof diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index c1f6ca8f..d29d0c7b 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -1211,11 +1211,11 @@ contains end subroutine l_mvect_free - subroutine l_mvect_ins(n,irl,val,x,info) + subroutine l_mvect_ins(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_l_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n,maxr integer(psb_ipk_), intent(in) :: irl(:) integer(psb_lpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info @@ -1228,7 +1228,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl,val,dupl,info) + call x%v%ins(n,irl,val,dupl,maxr,info) end subroutine l_mvect_ins diff --git a/base/modules/serial/psb_s_base_vect_mod.F90 b/base/modules/serial/psb_s_base_vect_mod.F90 index 7bb3f5fe..d5628e31 100644 --- a/base/modules/serial/psb_s_base_vect_mod.F90 +++ b/base/modules/serial/psb_s_base_vect_mod.F90 @@ -404,22 +404,6 @@ contains end subroutine s_base_all - subroutine s_base_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) then - call x%sync() - x%v(:) = szero - call x%set_host() - call x%set_upd() - end if - - end subroutine s_base_reinit - !> Function base_mold: !! \memberof psb_s_base_vect_type !! \brief Mold method: return a variable with the same dynamic type @@ -438,6 +422,22 @@ contains end subroutine s_base_mold + subroutine s_base_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_s_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:) = szero + call x%set_host() + call x%set_upd() + end if + + end subroutine s_base_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -498,7 +498,9 @@ contains end if enddo call x%set_ncfs(k) + else if (x%is_upd()) then + dupl_ = x%get_dupl() if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ @@ -669,7 +671,7 @@ contains ncfs = x%get_ncfs() xvsz = psb_size(x%v) call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = szero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,ncfs @@ -681,7 +683,7 @@ contains end do case(psb_dupl_err_) do i=1,ncfs - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. szero) then call psb_errpush(psb_err_duplicate_coo,'vect-asb') return else @@ -752,7 +754,7 @@ contains & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') if (x%is_bld()) then call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = szero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,x%get_ncfs() @@ -764,7 +766,7 @@ contains end do case(psb_dupl_err_) do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. szero) then call psb_errpush(psb_err_duplicate_coo,'vect_asb') return else @@ -822,8 +824,6 @@ contains call x%set_null() end subroutine s_base_free - - ! !> Function base_free_buffer: !! \memberof psb_s_base_vect_type @@ -2619,6 +2619,18 @@ module psb_s_base_multivect_mod real(psb_spk_), allocatable :: v(:,:) real(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -2637,6 +2649,22 @@ module psb_s_base_multivect_mod procedure, pass(x) :: zero => s_base_mlv_zero procedure, pass(x) :: asb => s_base_mlv_asb procedure, pass(x) :: free => s_base_mlv_free + procedure, pass(x) :: reinit => s_base_mlv_reinit + procedure, pass(x) :: set_ncfs => s_base_mlv_set_ncfs + procedure, pass(x) :: get_ncfs => s_base_mlv_get_ncfs + procedure, pass(x) :: set_dupl => s_base_mlv_set_dupl + procedure, pass(x) :: get_dupl => s_base_mlv_get_dupl + procedure, pass(x) :: set_state => s_base_mlv_set_state + procedure, pass(x) :: set_null => s_base_mlv_set_null + procedure, pass(x) :: set_bld => s_base_mlv_set_bld + procedure, pass(x) :: set_upd => s_base_mlv_set_upd + procedure, pass(x) :: set_asb => s_base_mlv_set_asb + procedure, pass(x) :: get_state => s_base_mlv_get_state + procedure, pass(x) :: is_null => s_base_mlv_is_null + procedure, pass(x) :: is_bld => s_base_mlv_is_bld + procedure, pass(x) :: is_upd => s_base_mlv_is_upd + procedure, pass(x) :: is_asb => s_base_mlv_is_asb + procedure, pass(x) :: base_cpy => s_base_mlv_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -2750,7 +2778,8 @@ contains integer(psb_ipk_) :: info this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) end function constructor @@ -2800,12 +2829,21 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine s_base_mlv_bld_n(x,m,n) + subroutine s_base_mlv_bld_n(x,m,n,scratch) use psb_realloc_mod integer(psb_ipk_), intent(in) :: m,n class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(m,n,x%v,info) call x%asb(m,n,info) @@ -2827,6 +2865,10 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if end subroutine s_base_mlv_all @@ -2848,6 +2890,22 @@ contains end subroutine s_base_mlv_mold + subroutine s_base_mlv_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_s_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = szero + call x%set_host() + call x%set_upd() + end if + + end subroutine s_base_mlv_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -2875,57 +2933,123 @@ contains !! \param info return code !! ! - subroutine s_base_mlv_ins(n,irl,val,dupl,x,info) + subroutine s_base_mlv_ins(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: irl(:) real(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k info = 0 if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ do i = 1, n !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 ! this row belongs to me ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) end if enddo + call x%set_ncfs(k) - case(psb_dupl_add_) + else if (x%is_upd()) then - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if end if + call x%set_host() if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return @@ -2945,6 +3069,7 @@ contains class(psb_s_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=szero + call x%set_host() end subroutine s_base_mlv_zero @@ -2963,19 +3088,73 @@ contains !! ! - subroutine s_base_mlv_asb(m,n, x, info) + subroutine s_base_mlv_asb(m,n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine s_base_mlv_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_s_base_multivect_type), intent(in) :: x + class(psb_s_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine s_base_mlv_cpy + ! ! Size info. @@ -3139,7 +3434,7 @@ contains integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * psb_sizeof_sp) * x%get_nrows() * x%get_ncols() end function s_base_mlv_sizeof diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index fab3fdb2..bb6a298f 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -1966,11 +1966,11 @@ contains end subroutine s_mvect_free - subroutine s_mvect_ins(n,irl,val,x,info) + subroutine s_mvect_ins(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_s_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n,maxr integer(psb_ipk_), intent(in) :: irl(:) real(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info @@ -1983,7 +1983,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl,val,dupl,info) + call x%v%ins(n,irl,val,dupl,maxr,info) end subroutine s_mvect_ins diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index 3c7383e6..cc437d4d 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -397,22 +397,6 @@ contains end subroutine z_base_all - subroutine z_base_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) then - call x%sync() - x%v(:) = zzero - call x%set_host() - call x%set_upd() - end if - - end subroutine z_base_reinit - !> Function base_mold: !! \memberof psb_z_base_vect_type !! \brief Mold method: return a variable with the same dynamic type @@ -431,6 +415,22 @@ contains end subroutine z_base_mold + subroutine z_base_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_z_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:) = zzero + call x%set_host() + call x%set_upd() + end if + + end subroutine z_base_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -491,7 +491,9 @@ contains end if enddo call x%set_ncfs(k) + else if (x%is_upd()) then + dupl_ = x%get_dupl() if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ @@ -662,7 +664,7 @@ contains ncfs = x%get_ncfs() xvsz = psb_size(x%v) call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = zzero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,ncfs @@ -674,7 +676,7 @@ contains end do case(psb_dupl_err_) do i=1,ncfs - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. zzero) then call psb_errpush(psb_err_duplicate_coo,'vect-asb') return else @@ -745,7 +747,7 @@ contains & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') if (x%is_bld()) then call psb_realloc(n,vv,info) - vv(:) = dzero + vv(:) = zzero select case(x%get_dupl()) case(psb_dupl_add_) do i=1,x%get_ncfs() @@ -757,7 +759,7 @@ contains end do case(psb_dupl_err_) do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne.dzero) then + if (vv(x%iv(i)).ne. zzero) then call psb_errpush(psb_err_duplicate_coo,'vect_asb') return else @@ -815,8 +817,6 @@ contains call x%set_null() end subroutine z_base_free - - ! !> Function base_free_buffer: !! \memberof psb_z_base_vect_type @@ -2440,6 +2440,18 @@ module psb_z_base_multivect_mod complex(psb_dpk_), allocatable :: v(:,:) complex(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -2458,6 +2470,22 @@ module psb_z_base_multivect_mod procedure, pass(x) :: zero => z_base_mlv_zero procedure, pass(x) :: asb => z_base_mlv_asb procedure, pass(x) :: free => z_base_mlv_free + procedure, pass(x) :: reinit => z_base_mlv_reinit + procedure, pass(x) :: set_ncfs => z_base_mlv_set_ncfs + procedure, pass(x) :: get_ncfs => z_base_mlv_get_ncfs + procedure, pass(x) :: set_dupl => z_base_mlv_set_dupl + procedure, pass(x) :: get_dupl => z_base_mlv_get_dupl + procedure, pass(x) :: set_state => z_base_mlv_set_state + procedure, pass(x) :: set_null => z_base_mlv_set_null + procedure, pass(x) :: set_bld => z_base_mlv_set_bld + procedure, pass(x) :: set_upd => z_base_mlv_set_upd + procedure, pass(x) :: set_asb => z_base_mlv_set_asb + procedure, pass(x) :: get_state => z_base_mlv_get_state + procedure, pass(x) :: is_null => z_base_mlv_is_null + procedure, pass(x) :: is_bld => z_base_mlv_is_bld + procedure, pass(x) :: is_upd => z_base_mlv_is_upd + procedure, pass(x) :: is_asb => z_base_mlv_is_asb + procedure, pass(x) :: base_cpy => z_base_mlv_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -2571,7 +2599,8 @@ contains integer(psb_ipk_) :: info this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) end function constructor @@ -2621,12 +2650,21 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine z_base_mlv_bld_n(x,m,n) + subroutine z_base_mlv_bld_n(x,m,n,scratch) use psb_realloc_mod integer(psb_ipk_), intent(in) :: m,n class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(m,n,x%v,info) call x%asb(m,n,info) @@ -2648,6 +2686,10 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if end subroutine z_base_mlv_all @@ -2669,6 +2711,22 @@ contains end subroutine z_base_mlv_mold + subroutine z_base_mlv_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_z_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = zzero + call x%set_host() + call x%set_upd() + end if + + end subroutine z_base_mlv_reinit + ! ! Insert a bunch of values at specified positions. ! @@ -2696,57 +2754,123 @@ contains !! \param info return code !! ! - subroutine z_base_mlv_ins(n,irl,val,dupl,x,info) + subroutine z_base_mlv_ins(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: irl(:) complex(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k info = 0 if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ do i = 1, n !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 ! this row belongs to me ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) end if enddo + call x%set_ncfs(k) - case(psb_dupl_add_) + else if (x%is_upd()) then - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if end if + call x%set_host() if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return @@ -2766,6 +2890,7 @@ contains class(psb_z_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=zzero + call x%set_host() end subroutine z_base_mlv_zero @@ -2784,19 +2909,73 @@ contains !! ! - subroutine z_base_mlv_asb(m,n, x, info) + subroutine z_base_mlv_asb(m,n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine z_base_mlv_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_z_base_multivect_type), intent(in) :: x + class(psb_z_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine z_base_mlv_cpy + ! ! Size info. @@ -2960,7 +3255,7 @@ contains integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * (2*psb_sizeof_dp)) * x%get_nrows() * x%get_ncols() end function z_base_mlv_sizeof diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 9d1d49d5..fbed40ca 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -1887,11 +1887,11 @@ contains end subroutine z_mvect_free - subroutine z_mvect_ins(n,irl,val,x,info) + subroutine z_mvect_ins(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_z_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n,maxr integer(psb_ipk_), intent(in) :: irl(:) complex(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info @@ -1904,7 +1904,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl,val,dupl,info) + call x%v%ins(n,irl,val,dupl,maxr,info) end subroutine z_mvect_ins diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index cb39593f..813ef370 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -80,7 +80,7 @@ Module psb_c_tools_mod logical, intent(in), optional :: scratch integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_casb_vect - subroutine psb_casb_vect_r2(x, desc_a, info,mold, scratch) + subroutine psb_casb_vect_r2(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -88,6 +88,7 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_casb_vect_r2 subroutine psb_casb_multivect(x, desc_a, info,mold, scratch, n) import diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index da305164..6ea554cd 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -80,7 +80,7 @@ Module psb_d_tools_mod logical, intent(in), optional :: scratch integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_dasb_vect - subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch) + subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -88,6 +88,7 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_dasb_vect_r2 subroutine psb_dasb_multivect(x, desc_a, info,mold, scratch, n) import diff --git a/base/modules/tools/psb_i_tools_mod.F90 b/base/modules/tools/psb_i_tools_mod.F90 index f0ccfb72..767dc8e5 100644 --- a/base/modules/tools/psb_i_tools_mod.F90 +++ b/base/modules/tools/psb_i_tools_mod.F90 @@ -79,7 +79,7 @@ Module psb_i_tools_mod logical, intent(in), optional :: scratch integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_iasb_vect - subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch) + subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -87,6 +87,7 @@ Module psb_i_tools_mod integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_iasb_vect_r2 subroutine psb_iasb_multivect(x, desc_a, info,mold, scratch, n) import diff --git a/base/modules/tools/psb_l_tools_mod.F90 b/base/modules/tools/psb_l_tools_mod.F90 index 56cdddcb..92fe875b 100644 --- a/base/modules/tools/psb_l_tools_mod.F90 +++ b/base/modules/tools/psb_l_tools_mod.F90 @@ -79,7 +79,7 @@ Module psb_l_tools_mod logical, intent(in), optional :: scratch integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_lasb_vect - subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch) + subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -87,6 +87,7 @@ Module psb_l_tools_mod integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_lasb_vect_r2 subroutine psb_lasb_multivect(x, desc_a, info,mold, scratch, n) import diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index f6e97208..d4fa7892 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -80,7 +80,7 @@ Module psb_s_tools_mod logical, intent(in), optional :: scratch integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_sasb_vect - subroutine psb_sasb_vect_r2(x, desc_a, info,mold, scratch) + subroutine psb_sasb_vect_r2(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -88,6 +88,7 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_sasb_vect_r2 subroutine psb_sasb_multivect(x, desc_a, info,mold, scratch, n) import diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index f0e42c75..2c105b2b 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -80,7 +80,7 @@ Module psb_z_tools_mod logical, intent(in), optional :: scratch integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_zasb_vect - subroutine psb_zasb_vect_r2(x, desc_a, info,mold, scratch) + subroutine psb_zasb_vect_r2(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -88,6 +88,7 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_zasb_vect_r2 subroutine psb_zasb_multivect(x, desc_a, info,mold, scratch, n) import diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index 85ccbf6a..39925b40 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -207,48 +207,11 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) goto 9999 endif endif - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (desc_a%is_asb().or.desc_a%is_upd()) then - nr = max(1,desc_a%get_local_cols()) - else if (desc_a%is_bld()) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid desc_a') - goto 9999 - endif - allocate(x(lb_:lb_+n_-1), stat=info) - if (info == 0) then - do i=lb_, lb_+n_-1 - allocate(psb_c_base_vect_type :: x(i)%v, stat=info) - if (info == 0) call x(i)%all(nr,info) - if (info == 0) call x(i)%zero() - if (info /= 0) exit - end do - end if - - if (present(bldmode)) then - bldmode_ = bldmode - else - bldmode_ = psb_matbld_noremote_ - end if - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - do i=lb_, lb_+n_-1 - call x(i)%set_dupl(dupl_) - call x(i)%set_remote_build(bldmode_) - if (x(i)%is_remote_build()) then - nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) - allocate(x(i)%rmtv(nrmt_)) - end if + call psb_geall(x(i),desc_a,info,dupl, bldmode) end do + if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') @@ -261,7 +224,6 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psb_calloc_vect_r2 diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index ad6e69d3..c8d2834c 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -188,7 +188,7 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch, dupl) end subroutine psb_casb_vect -subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) +subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch,dupl) use psb_base_mod, psb_protect_name => psb_casb_vect_r2 implicit none @@ -197,12 +197,12 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl ! local variables type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, i, n - integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_ - logical :: scratch_ + integer(psb_ipk_) :: err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -217,8 +217,6 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -230,35 +228,11 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) call psb_errpush(info,name) goto 9999 end if - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() n = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + do i=1, n + call psb_geasb(x(i),desc_a,info, mold, scratch, dupl) + end do - if (scratch_) then - do i=1,n - call x(i)%free(info) - call x(i)%bld(ncol,mold=mold) - end do - - else - do i=1, n - dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info,scratch=scratch) - if (info /= 0) exit - ! ..update halo elements.. - call psb_halo(x(i),desc_a,info) - if (info /= 0) exit - call x(i)%cnv(mold) - end do - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 - end if - end if if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index ee0391a1..1c14b7b2 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -475,7 +475,7 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,info) + call x%ins(m,irl,val,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index a8ef4672..942ccb74 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -207,48 +207,11 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) goto 9999 endif endif - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (desc_a%is_asb().or.desc_a%is_upd()) then - nr = max(1,desc_a%get_local_cols()) - else if (desc_a%is_bld()) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid desc_a') - goto 9999 - endif - allocate(x(lb_:lb_+n_-1), stat=info) - if (info == 0) then - do i=lb_, lb_+n_-1 - allocate(psb_d_base_vect_type :: x(i)%v, stat=info) - if (info == 0) call x(i)%all(nr,info) - if (info == 0) call x(i)%zero() - if (info /= 0) exit - end do - end if - - if (present(bldmode)) then - bldmode_ = bldmode - else - bldmode_ = psb_matbld_noremote_ - end if - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - do i=lb_, lb_+n_-1 - call x(i)%set_dupl(dupl_) - call x(i)%set_remote_build(bldmode_) - if (x(i)%is_remote_build()) then - nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) - allocate(x(i)%rmtv(nrmt_)) - end if + call psb_geall(x(i),desc_a,info,dupl, bldmode) end do + if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') @@ -261,7 +224,6 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psb_dalloc_vect_r2 diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index eb15dc1a..74970cc7 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -188,7 +188,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch, dupl) end subroutine psb_dasb_vect -subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) +subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch,dupl) use psb_base_mod, psb_protect_name => psb_dasb_vect_r2 implicit none @@ -197,12 +197,12 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl ! local variables type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, i, n - integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_ - logical :: scratch_ + integer(psb_ipk_) :: err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -217,8 +217,6 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -230,35 +228,11 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) call psb_errpush(info,name) goto 9999 end if - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() n = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + do i=1, n + call psb_geasb(x(i),desc_a,info, mold, scratch, dupl) + end do - if (scratch_) then - do i=1,n - call x(i)%free(info) - call x(i)%bld(ncol,mold=mold) - end do - - else - do i=1, n - dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info,scratch=scratch) - if (info /= 0) exit - ! ..update halo elements.. - call psb_halo(x(i),desc_a,info) - if (info /= 0) exit - call x(i)%cnv(mold) - end do - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 - end if - end if if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index daac9767..eca13da7 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -475,7 +475,7 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,info) + call x%ins(m,irl,val,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index 95558fe2..75b560e6 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -207,48 +207,11 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) goto 9999 endif endif - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (desc_a%is_asb().or.desc_a%is_upd()) then - nr = max(1,desc_a%get_local_cols()) - else if (desc_a%is_bld()) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid desc_a') - goto 9999 - endif - allocate(x(lb_:lb_+n_-1), stat=info) - if (info == 0) then - do i=lb_, lb_+n_-1 - allocate(psb_i_base_vect_type :: x(i)%v, stat=info) - if (info == 0) call x(i)%all(nr,info) - if (info == 0) call x(i)%zero() - if (info /= 0) exit - end do - end if - - if (present(bldmode)) then - bldmode_ = bldmode - else - bldmode_ = psb_matbld_noremote_ - end if - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - do i=lb_, lb_+n_-1 - call x(i)%set_dupl(dupl_) - call x(i)%set_remote_build(bldmode_) - if (x(i)%is_remote_build()) then - nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) - allocate(x(i)%rmtv(nrmt_)) - end if + call psb_geall(x(i),desc_a,info,dupl, bldmode) end do + if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') @@ -261,7 +224,6 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psb_ialloc_vect_r2 diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index ec8536b9..474b8934 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -188,7 +188,7 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch, dupl) end subroutine psb_iasb_vect -subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) +subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch,dupl) use psb_base_mod, psb_protect_name => psb_iasb_vect_r2 implicit none @@ -197,12 +197,12 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl ! local variables type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, i, n - integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_ - logical :: scratch_ + integer(psb_ipk_) :: err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -217,8 +217,6 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -230,35 +228,11 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) call psb_errpush(info,name) goto 9999 end if - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() n = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + do i=1, n + call psb_geasb(x(i),desc_a,info, mold, scratch, dupl) + end do - if (scratch_) then - do i=1,n - call x(i)%free(info) - call x(i)%bld(ncol,mold=mold) - end do - - else - do i=1, n - dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info,scratch=scratch) - if (info /= 0) exit - ! ..update halo elements.. - call psb_halo(x(i),desc_a,info) - if (info /= 0) exit - call x(i)%cnv(mold) - end do - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 - end if - end if if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index 598af33f..bf02deb1 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -475,7 +475,7 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,info) + call x%ins(m,irl,val,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_lallc.f90 b/base/tools/psb_lallc.f90 index 8bb369c3..7d47b7cb 100644 --- a/base/tools/psb_lallc.f90 +++ b/base/tools/psb_lallc.f90 @@ -207,48 +207,11 @@ subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) goto 9999 endif endif - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (desc_a%is_asb().or.desc_a%is_upd()) then - nr = max(1,desc_a%get_local_cols()) - else if (desc_a%is_bld()) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid desc_a') - goto 9999 - endif - allocate(x(lb_:lb_+n_-1), stat=info) - if (info == 0) then - do i=lb_, lb_+n_-1 - allocate(psb_l_base_vect_type :: x(i)%v, stat=info) - if (info == 0) call x(i)%all(nr,info) - if (info == 0) call x(i)%zero() - if (info /= 0) exit - end do - end if - - if (present(bldmode)) then - bldmode_ = bldmode - else - bldmode_ = psb_matbld_noremote_ - end if - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - do i=lb_, lb_+n_-1 - call x(i)%set_dupl(dupl_) - call x(i)%set_remote_build(bldmode_) - if (x(i)%is_remote_build()) then - nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) - allocate(x(i)%rmtv(nrmt_)) - end if + call psb_geall(x(i),desc_a,info,dupl, bldmode) end do + if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') @@ -261,7 +224,6 @@ subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psb_lalloc_vect_r2 diff --git a/base/tools/psb_lasb.f90 b/base/tools/psb_lasb.f90 index 61e3de94..3f0ba467 100644 --- a/base/tools/psb_lasb.f90 +++ b/base/tools/psb_lasb.f90 @@ -188,7 +188,7 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch, dupl) end subroutine psb_lasb_vect -subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) +subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch,dupl) use psb_base_mod, psb_protect_name => psb_lasb_vect_r2 implicit none @@ -197,12 +197,12 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl ! local variables type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, i, n - integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_ - logical :: scratch_ + integer(psb_ipk_) :: err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -217,8 +217,6 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -230,35 +228,11 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) call psb_errpush(info,name) goto 9999 end if - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() n = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + do i=1, n + call psb_geasb(x(i),desc_a,info, mold, scratch, dupl) + end do - if (scratch_) then - do i=1,n - call x(i)%free(info) - call x(i)%bld(ncol,mold=mold) - end do - - else - do i=1, n - dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info,scratch=scratch) - if (info /= 0) exit - ! ..update halo elements.. - call psb_halo(x(i),desc_a,info) - if (info /= 0) exit - call x(i)%cnv(mold) - end do - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 - end if - end if if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_lins.f90 b/base/tools/psb_lins.f90 index dc41d022..a3548571 100644 --- a/base/tools/psb_lins.f90 +++ b/base/tools/psb_lins.f90 @@ -475,7 +475,7 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,info) + call x%ins(m,irl,val,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 7e6649dd..00ab3812 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -207,48 +207,11 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) goto 9999 endif endif - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (desc_a%is_asb().or.desc_a%is_upd()) then - nr = max(1,desc_a%get_local_cols()) - else if (desc_a%is_bld()) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid desc_a') - goto 9999 - endif - allocate(x(lb_:lb_+n_-1), stat=info) - if (info == 0) then - do i=lb_, lb_+n_-1 - allocate(psb_s_base_vect_type :: x(i)%v, stat=info) - if (info == 0) call x(i)%all(nr,info) - if (info == 0) call x(i)%zero() - if (info /= 0) exit - end do - end if - - if (present(bldmode)) then - bldmode_ = bldmode - else - bldmode_ = psb_matbld_noremote_ - end if - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - do i=lb_, lb_+n_-1 - call x(i)%set_dupl(dupl_) - call x(i)%set_remote_build(bldmode_) - if (x(i)%is_remote_build()) then - nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) - allocate(x(i)%rmtv(nrmt_)) - end if + call psb_geall(x(i),desc_a,info,dupl, bldmode) end do + if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') @@ -261,7 +224,6 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psb_salloc_vect_r2 diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index 0fe6f545..6d667dc9 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -188,7 +188,7 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch, dupl) end subroutine psb_sasb_vect -subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) +subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch,dupl) use psb_base_mod, psb_protect_name => psb_sasb_vect_r2 implicit none @@ -197,12 +197,12 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl ! local variables type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, i, n - integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_ - logical :: scratch_ + integer(psb_ipk_) :: err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -217,8 +217,6 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -230,35 +228,11 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) call psb_errpush(info,name) goto 9999 end if - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() n = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + do i=1, n + call psb_geasb(x(i),desc_a,info, mold, scratch, dupl) + end do - if (scratch_) then - do i=1,n - call x(i)%free(info) - call x(i)%bld(ncol,mold=mold) - end do - - else - do i=1, n - dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info,scratch=scratch) - if (info /= 0) exit - ! ..update halo elements.. - call psb_halo(x(i),desc_a,info) - if (info /= 0) exit - call x(i)%cnv(mold) - end do - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 - end if - end if if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index 25c7248a..ec9988f8 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -475,7 +475,7 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,info) + call x%ins(m,irl,val,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index 96d567fc..de6e91b0 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -207,48 +207,11 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) goto 9999 endif endif - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (desc_a%is_asb().or.desc_a%is_upd()) then - nr = max(1,desc_a%get_local_cols()) - else if (desc_a%is_bld()) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid desc_a') - goto 9999 - endif - allocate(x(lb_:lb_+n_-1), stat=info) - if (info == 0) then - do i=lb_, lb_+n_-1 - allocate(psb_z_base_vect_type :: x(i)%v, stat=info) - if (info == 0) call x(i)%all(nr,info) - if (info == 0) call x(i)%zero() - if (info /= 0) exit - end do - end if - - if (present(bldmode)) then - bldmode_ = bldmode - else - bldmode_ = psb_matbld_noremote_ - end if - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - do i=lb_, lb_+n_-1 - call x(i)%set_dupl(dupl_) - call x(i)%set_remote_build(bldmode_) - if (x(i)%is_remote_build()) then - nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) - allocate(x(i)%rmtv(nrmt_)) - end if + call psb_geall(x(i),desc_a,info,dupl, bldmode) end do + if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') @@ -261,7 +224,6 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode) 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psb_zalloc_vect_r2 diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index e21eaf7f..b8d797ec 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -188,7 +188,7 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch, dupl) end subroutine psb_zasb_vect -subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) +subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch,dupl) use psb_base_mod, psb_protect_name => psb_zasb_vect_r2 implicit none @@ -197,12 +197,12 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl ! local variables type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, i, n - integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_ - logical :: scratch_ + integer(psb_ipk_) :: err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -217,8 +217,6 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -230,35 +228,11 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) call psb_errpush(info,name) goto 9999 end if - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() n = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + do i=1, n + call psb_geasb(x(i),desc_a,info, mold, scratch, dupl) + end do - if (scratch_) then - do i=1,n - call x(i)%free(info) - call x(i)%bld(ncol,mold=mold) - end do - - else - do i=1, n - dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info,scratch=scratch) - if (info /= 0) exit - ! ..update halo elements.. - call psb_halo(x(i),desc_a,info) - if (info /= 0) exit - call x(i)%cnv(mold) - end do - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 - end if - end if if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index 1c16eb96..8e8b2afd 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -475,7 +475,7 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,info) + call x%ins(m,irl,val,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999