From 0c84efb887a7c0b2796f937d93510f00ebaad947 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 6 Nov 2025 14:06:47 +0100 Subject: [PATCH] Working version with mods for building with dealii requests --- base/modules/psb_const_mod.F90 | 2 +- base/modules/serial/psb_c_base_vect_mod.F90 | 432 ++++++++++++++++--- base/modules/serial/psb_c_vect_mod.F90 | 174 +++++++- base/modules/serial/psb_d_base_vect_mod.F90 | 249 ++++++----- base/modules/serial/psb_d_vect_mod.F90 | 57 ++- base/modules/serial/psb_i_base_vect_mod.F90 | 434 +++++++++++++++++--- base/modules/serial/psb_i_vect_mod.F90 | 174 +++++++- base/modules/serial/psb_l_base_vect_mod.F90 | 434 +++++++++++++++++--- base/modules/serial/psb_l_vect_mod.F90 | 174 +++++++- base/modules/serial/psb_s_base_vect_mod.F90 | 432 ++++++++++++++++--- base/modules/serial/psb_s_vect_mod.F90 | 174 +++++++- base/modules/serial/psb_z_base_vect_mod.F90 | 432 ++++++++++++++++--- base/modules/serial/psb_z_vect_mod.F90 | 174 +++++++- base/modules/tools/psb_c_tools_mod.F90 | 6 +- base/modules/tools/psb_d_tools_mod.F90 | 4 +- 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 | 6 +- base/modules/tools/psb_z_tools_mod.F90 | 6 +- base/tools/psb_callc.f90 | 8 +- base/tools/psb_casb.f90 | 110 +++-- base/tools/psb_cins.f90 | 10 +- base/tools/psb_cspasb.f90 | 12 +- base/tools/psb_dallc.f90 | 9 +- base/tools/psb_dasb.f90 | 34 +- base/tools/psb_dins.f90 | 4 +- base/tools/psb_dspins.F90 | 6 +- base/tools/psb_iallc.f90 | 8 +- base/tools/psb_iasb.f90 | 110 +++-- base/tools/psb_iins.f90 | 10 +- base/tools/psb_lallc.f90 | 8 +- base/tools/psb_lasb.f90 | 110 +++-- base/tools/psb_lins.f90 | 10 +- base/tools/psb_sallc.f90 | 8 +- base/tools/psb_sasb.f90 | 110 +++-- base/tools/psb_sins.f90 | 10 +- base/tools/psb_sspasb.f90 | 12 +- base/tools/psb_zallc.f90 | 8 +- base/tools/psb_zasb.f90 | 110 +++-- base/tools/psb_zins.f90 | 10 +- base/tools/psb_zspasb.f90 | 12 +- cuda/psb_c_cuda_vect_mod.F90 | 48 ++- cuda/psb_d_cuda_vect_mod.F90 | 40 +- cuda/psb_i_cuda_vect_mod.F90 | 48 ++- cuda/psb_s_cuda_vect_mod.F90 | 48 ++- cuda/psb_z_cuda_vect_mod.F90 | 48 ++- openacc/psb_c_oacc_vect_mod.F90 | 47 ++- openacc/psb_d_oacc_vect_mod.F90 | 47 ++- openacc/psb_i_oacc_vect_mod.F90 | 47 ++- openacc/psb_l_oacc_vect_mod.F90 | 47 ++- openacc/psb_s_oacc_vect_mod.F90 | 47 ++- openacc/psb_z_oacc_vect_mod.F90 | 47 ++- test/pdegen/psb_d_pde2d.F90 | 12 +- test/pdegen/psb_d_pde3d.F90 | 4 +- test/pdegen/psb_s_pde2d.F90 | 12 +- test/pdegen/psb_s_pde3d.F90 | 12 +- 56 files changed, 3760 insertions(+), 893 deletions(-) diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index f1e8949b..e3509811 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -332,7 +332,7 @@ module psb_const_mod contains procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt end type psb_ctxt_type - + logical, parameter :: try_newins=.true. contains function psb_cmp_ctxt(ctxt1, ctxt2) result(res) diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index 65286969..3f4eb658 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -65,6 +65,18 @@ module psb_c_base_vect_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 @@ -88,6 +100,21 @@ module psb_c_base_vect_mod procedure, pass(x) :: asb_e => c_base_asb_e generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => c_base_free + procedure, pass(x) :: reinit => c_base_reinit + procedure, pass(x) :: set_ncfs => c_base_set_ncfs + procedure, pass(x) :: get_ncfs => c_base_get_ncfs + procedure, pass(x) :: set_dupl => c_base_set_dupl + procedure, pass(x) :: get_dupl => c_base_get_dupl + procedure, pass(x) :: set_state => c_base_set_state + procedure, pass(x) :: set_null => c_base_set_null + procedure, pass(x) :: set_bld => c_base_set_bld + procedure, pass(x) :: set_upd => c_base_set_upd + procedure, pass(x) :: set_asb => c_base_set_asb + procedure, pass(x) :: get_state => c_base_get_state + procedure, pass(x) :: is_null => c_base_is_null + procedure, pass(x) :: is_bld => c_base_is_bld + procedure, pass(x) :: is_upd => c_base_is_upd + procedure, pass(x) :: is_asb => c_base_is_asb ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -211,8 +238,6 @@ module psb_c_base_vect_mod generic, public :: addconst => addconst_a2,addconst_v2 - - end type psb_c_base_vect_type public :: psb_c_base_vect @@ -263,14 +288,22 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine c_base_bld_x(x,this) + subroutine c_base_bld_x(x,this,scratch) use psb_realloc_mod implicit none complex(psb_spk_), intent(in) :: this(:) class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info integer(psb_ipk_) :: i + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(size(this),x%v,info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') @@ -295,15 +328,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine c_base_bld_mn(x,n) + subroutine c_base_bld_mn(x,n,scratch) use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine c_base_bld_mn @@ -312,15 +353,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine c_base_bld_en(x,n) + subroutine c_base_bld_en(x,n,scratch) use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine c_base_bld_en @@ -340,9 +389,29 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(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_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 @@ -388,55 +457,116 @@ contains !! \param info return code !! ! - subroutine c_base_ins_a(n,irl,val,dupl,x,info) + subroutine c_base_ins_a(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_c_base_vect_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, 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) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,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 - ! 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 + 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)) = x%v(irl(i)) + val(i) + x%v(k) = val(i) + x%iv(k) = irl(i) 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_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + 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_ - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + else + isz = size(x%v) + 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 + end if end if call x%set_host() if (info /= 0) then @@ -446,11 +576,11 @@ contains end subroutine c_base_ins_a - subroutine c_base_ins_v(n,irl,val,dupl,x,info) + subroutine c_base_ins_v(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl, maxr class(psb_i_base_vect_type), intent(inout) :: irl class(psb_c_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -463,7 +593,7 @@ contains if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,info) + call x%ins(n,irl%v,val%v,dupl,maxr,info) if (info /= 0) then call psb_errpush(info,'base_vect_ins') @@ -507,19 +637,70 @@ contains !! ! - subroutine c_base_asb_m(n, x, info) + subroutine c_base_asb_m(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_spk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine c_base_asb_m @@ -537,19 +718,70 @@ contains !! ! - subroutine c_base_asb_e(n, x, info) + subroutine c_base_asb_e(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_spk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine c_base_asb_e @@ -572,9 +804,10 @@ contains if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + call x%set_null() end subroutine c_base_free @@ -637,7 +870,104 @@ contains if (allocated(x%comid)) & & deallocate(x%comid,stat=info) end subroutine c_base_free_comid + + function c_base_get_ncfs(x) result(res) + implicit none + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function c_base_get_ncfs + + function c_base_get_dupl(x) result(res) + implicit none + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function c_base_get_dupl + + function c_base_get_state(x) result(res) + implicit none + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function c_base_get_state + + function c_base_is_null(x) result(res) + implicit none + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function c_base_is_null + + function c_base_is_bld(x) result(res) + implicit none + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function c_base_is_bld + + function c_base_is_upd(x) result(res) + implicit none + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function c_base_is_upd + + function c_base_is_asb(x) result(res) + implicit none + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function c_base_is_asb + + subroutine c_base_set_ncfs(n,x) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine c_base_set_ncfs + + subroutine c_base_set_dupl(n,x) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine c_base_set_dupl + + subroutine c_base_set_state(n,x) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine c_base_set_state + + subroutine c_base_set_null(x) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine c_base_set_null + + subroutine c_base_set_bld(x) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine c_base_set_bld + + subroutine c_base_set_upd(x) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine c_base_set_upd + + subroutine c_base_set_asb(x) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + x%bldstate = psb_vect_asb_ + end subroutine c_base_set_asb ! ! The base version of SYNC & friends does nothing, it's just diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index 9effe9ef..c820d937 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -56,14 +56,26 @@ module psb_c_vect_mod procedure, pass(x) :: get_fmt => c_vect_get_fmt procedure, pass(x) :: is_remote_build => c_vect_is_remote_build procedure, pass(x) :: set_remote_build => c_vect_set_remote_build - procedure, pass(x) :: get_dupl => c_vect_get_dupl - procedure, pass(x) :: set_dupl => c_vect_set_dupl procedure, pass(x) :: get_nrmv => c_vect_get_nrmv procedure, pass(x) :: set_nrmv => c_vect_set_nrmv procedure, pass(x) :: all => c_vect_all procedure, pass(x) :: reall => c_vect_reall procedure, pass(x) :: zero => c_vect_zero procedure, pass(x) :: asb => c_vect_asb + procedure, pass(x) :: set_dupl => c_vect_set_dupl + procedure, pass(x) :: get_dupl => c_vect_get_dupl + procedure, pass(x) :: set_state => c_vect_set_state + procedure, pass(x) :: set_null => c_vect_set_null + procedure, pass(x) :: set_bld => c_vect_set_bld + procedure, pass(x) :: set_upd => c_vect_set_upd + procedure, pass(x) :: set_asb => c_vect_set_asb + procedure, pass(x) :: get_state => c_vect_get_state + procedure, pass(x) :: is_null => c_vect_is_null + procedure, pass(x) :: is_bld => c_vect_is_bld + procedure, pass(x) :: is_upd => c_vect_is_upd + procedure, pass(x) :: is_asb => c_vect_is_asb + procedure, pass(x) :: reinit => c_vect_reinit + procedure, pass(x) :: gthab => c_vect_gthab procedure, pass(x) :: gthzv => c_vect_gthzv generic, public :: gth => gthab, gthzv @@ -187,7 +199,11 @@ contains implicit none class(psb_c_vect_type), intent(in) :: x integer(psb_ipk_) :: res - res = x%dupl + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if end function c_vect_get_dupl subroutine c_vect_set_dupl(x,val) @@ -195,13 +211,92 @@ contains class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in), optional :: val - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if end if end subroutine c_vect_set_dupl + function c_vect_get_state(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function c_vect_get_state + + function c_vect_is_null(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function c_vect_is_null + + function c_vect_is_bld(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function c_vect_is_bld + + function c_vect_is_upd(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function c_vect_is_upd + + function c_vect_is_asb(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function c_vect_is_asb + + subroutine c_vect_set_state(n,x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine c_vect_set_state + + + subroutine c_vect_set_null(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine c_vect_set_null + + subroutine c_vect_set_bld(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine c_vect_set_bld + + subroutine c_vect_set_upd(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine c_vect_set_upd + + subroutine c_vect_set_asb(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine c_vect_set_asb + function c_vect_get_nrmv(x) result(res) implicit none class(psb_c_vect_type), intent(in) :: x @@ -291,12 +386,21 @@ contains end if end subroutine c_vect_clone - subroutine c_vect_bld_x(x,invect,mold) + subroutine c_vect_bld_x(x,invect,mold,scratch) complex(psb_spk_), intent(in) :: invect(:) class(psb_c_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + info = psb_success_ if (allocated(x%v)) & & call x%free(info) @@ -307,17 +411,25 @@ contains allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(invect) + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) end subroutine c_vect_bld_x - subroutine c_vect_bld_mn(x,n,mold) + subroutine c_vect_bld_mn(x,n,mold,scratch) integer(psb_mpk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info class(psb_c_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if info = psb_success_ if (allocated(x%v)) & @@ -328,17 +440,25 @@ contains else allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine c_vect_bld_mn - subroutine c_vect_bld_en(x,n,mold) + subroutine c_vect_bld_en(x,n,mold,scratch) integer(psb_epk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (allocated(x%v)) & & call x%free(info) @@ -348,7 +468,7 @@ contains else allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine c_vect_bld_en @@ -450,8 +570,19 @@ contains else info = psb_err_alloc_dealloc_ end if + call x%set_bld() end subroutine c_vect_all + subroutine c_vect_reinit(x, info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) call x%v%reinit(info) + call x%set_upd() + + end subroutine c_vect_reinit + subroutine c_vect_reall(n, x, info) implicit none @@ -476,16 +607,17 @@ contains end subroutine c_vect_zero - subroutine c_vect_asb(n, x, info) + subroutine c_vect_asb(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch if (allocated(x%v)) then - call x%v%asb(n,info) + call x%v%asb(n,info,scratch=scratch) end if end subroutine c_vect_asb @@ -540,11 +672,11 @@ contains end subroutine c_vect_free - subroutine c_vect_ins_a(n,irl,val,x,info) + subroutine c_vect_ins_a(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_c_vect_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 @@ -557,15 +689,15 @@ 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_vect_ins_a - subroutine c_vect_ins_v(n,irl,val,x,info) + subroutine c_vect_ins_v(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n, maxr class(psb_i_vect_type), intent(inout) :: irl class(psb_c_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -578,7 +710,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl%v,val%v,dupl,info) + call x%v%ins(n,irl%v,val%v,dupl,maxr,info) end subroutine c_vect_ins_v diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index 3860d655..7a3026ea 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -73,9 +73,9 @@ module psb_d_base_vect_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_vect_mod. - integer(psb_ipk_), private :: bldstate - integer(psb_ipk_), private :: dupl = psb_dupl_null_ - integer(psb_ipk_), private :: ncfs + 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 ! @@ -89,15 +89,17 @@ module psb_d_base_vect_mod procedure, pass(x) :: mold => d_base_mold ! ! Insert/set. Assembly and free. + ! Assembly does almost nothing here, but is important + ! in derived classes. ! - procedure, pass(x) :: ins_a => d_base_ins_a - procedure, pass(x) :: ins_v => d_base_ins_v - generic, public :: ins => ins_a, ins_v - procedure, pass(x) :: zero => d_base_zero - procedure, pass(x) :: asb_m => d_base_asb_m - procedure, pass(x) :: asb_e => d_base_asb_e - generic, public :: asb => asb_m, asb_e - procedure, pass(x) :: free => d_base_free + procedure, pass(x) :: ins_a => d_base_ins_a + procedure, pass(x) :: ins_v => d_base_ins_v + generic, public :: ins => ins_a, ins_v + procedure, pass(x) :: zero => d_base_zero + procedure, pass(x) :: asb_m => d_base_asb_m + procedure, pass(x) :: asb_e => d_base_asb_e + generic, public :: asb => asb_m, asb_e + procedure, pass(x) :: free => d_base_free procedure, pass(x) :: reinit => d_base_reinit procedure, pass(x) :: set_ncfs => d_base_set_ncfs procedure, pass(x) :: get_ncfs => d_base_get_ncfs @@ -243,8 +245,6 @@ module psb_d_base_vect_mod procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2 generic, public :: minquotient => minquotient_v, minquotient_a2 - - end type psb_d_base_vect_type public :: psb_d_base_vect @@ -253,7 +253,6 @@ module psb_d_base_vect_mod module procedure constructor, size_const end interface psb_d_base_vect - logical, parameter :: try_newins=.true. contains ! @@ -296,14 +295,22 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine d_base_bld_x(x,this) + subroutine d_base_bld_x(x,this,scratch) use psb_realloc_mod implicit none real(psb_dpk_), intent(in) :: this(:) class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info integer(psb_ipk_) :: i + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(size(this),x%v,info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') @@ -328,15 +335,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine d_base_bld_mn(x,n) + subroutine d_base_bld_mn(x,n,scratch) use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine d_base_bld_mn @@ -345,15 +360,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine d_base_bld_en(x,n) + subroutine d_base_bld_en(x,n,scratch) use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine d_base_bld_en @@ -373,10 +396,10 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(n,x%v,info) -#ifdef TRY_NEWINS - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) -#endif + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if end subroutine d_base_all @@ -391,6 +414,7 @@ contains call x%sync() x%v(:) = dzero call x%set_host() + call x%set_upd() end if end subroutine d_base_reinit @@ -444,7 +468,7 @@ contains use psi_serial_mod implicit none class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr + 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 @@ -453,56 +477,97 @@ contains info = 0 if (psb_errstatus_fatal()) return -#ifdef TRY_NEWINS - if (x%is_bld()) then - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_ensure_size(isz,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) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k) = val(i) - x%iv(k) = irl(i) + + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,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) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k) = val(i) + x%iv(k) = irl(i) + 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_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + 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 - enddo - call x%set_ncfs(k) + else + info = psb_err_invalid_vect_state_ + end if else - 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) - select case(dupl_) + 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 + 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) <= maxr)) then + 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) @@ -510,44 +575,6 @@ contains end select end if 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) - 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 - end if -#endif call x%set_host() if (info /= 0) then call psb_errpush(info,'base_vect_ins') @@ -560,7 +587,7 @@ contains use psi_serial_mod implicit none class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: n, dupl, maxr class(psb_i_base_vect_type), intent(inout) :: irl class(psb_d_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -617,17 +644,25 @@ contains !! ! - subroutine d_base_asb_m(n, x, info) + subroutine d_base_asb_m(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i,ncfs,xvsz + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz real(psb_dpk_), allocatable :: vv(:) + info = 0 - + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (try_newins) then if (x%is_bld()) then ncfs = x%get_ncfs() @@ -658,11 +693,14 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else + else if (x%is_upd().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') end if else if (x%get_nrows() < n) & @@ -687,17 +725,25 @@ contains !! ! - subroutine d_base_asb_e(n, x, info) + subroutine d_base_asb_e(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, j + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz real(psb_dpk_), allocatable :: vv(:) - info = 0 + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (try_newins) then if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') @@ -728,11 +774,14 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else + else if (x%is_upd().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') end if else if (x%get_nrows() < n) & @@ -741,7 +790,6 @@ contains & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') end if call x%sync() - end subroutine d_base_asb_e ! @@ -763,9 +811,10 @@ contains if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + call x%set_null() end subroutine d_base_free @@ -828,7 +877,7 @@ contains if (allocated(x%comid)) & & deallocate(x%comid,stat=info) end subroutine d_base_free_comid - + function d_base_get_ncfs(x) result(res) implicit none class(psb_d_base_vect_type), intent(in) :: x @@ -926,7 +975,7 @@ contains x%bldstate = psb_vect_asb_ end subroutine d_base_set_asb - + ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index c52946cf..7fd1a400 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -45,8 +45,9 @@ module psb_d_vect_mod type psb_d_vect_type class(psb_d_base_vect_type), allocatable :: v - integer(psb_ipk_) :: nrmv = 0 - integer(psb_ipk_) :: remote_build = psb_matbld_noremote_ + integer(psb_ipk_) :: nrmv = 0 + integer(psb_ipk_) :: remote_build=psb_matbld_noremote_ + integer(psb_ipk_) :: dupl = psb_dupl_add_ real(psb_dpk_), allocatable :: rmtv(:) integer(psb_lpk_), allocatable :: rmidx(:) contains @@ -74,7 +75,7 @@ module psb_d_vect_mod procedure, pass(x) :: is_upd => d_vect_is_upd procedure, pass(x) :: is_asb => d_vect_is_asb procedure, pass(x) :: reinit => d_vect_reinit - + procedure, pass(x) :: gthab => d_vect_gthab procedure, pass(x) :: gthzv => d_vect_gthzv generic, public :: gth => gthab, gthzv @@ -303,7 +304,6 @@ contains call x%set_state(psb_vect_asb_) end subroutine d_vect_set_asb - function d_vect_get_nrmv(x) result(res) implicit none class(psb_d_vect_type), intent(in) :: x @@ -393,12 +393,21 @@ contains end if end subroutine d_vect_clone - subroutine d_vect_bld_x(x,invect,mold) + subroutine d_vect_bld_x(x,invect,mold,scratch) real(psb_dpk_), intent(in) :: invect(:) class(psb_d_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + info = psb_success_ if (allocated(x%v)) & & call x%free(info) @@ -409,17 +418,25 @@ contains allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(invect) + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) end subroutine d_vect_bld_x - subroutine d_vect_bld_mn(x,n,mold) + subroutine d_vect_bld_mn(x,n,mold,scratch) integer(psb_mpk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info class(psb_d_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if info = psb_success_ if (allocated(x%v)) & @@ -430,17 +447,25 @@ contains else allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine d_vect_bld_mn - subroutine d_vect_bld_en(x,n,mold) + subroutine d_vect_bld_en(x,n,mold,scratch) integer(psb_epk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (allocated(x%v)) & & call x%free(info) @@ -450,7 +475,7 @@ contains else allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine d_vect_bld_en @@ -556,7 +581,6 @@ contains end subroutine d_vect_all subroutine d_vect_reinit(x, info) - implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -565,7 +589,7 @@ contains call x%set_upd() end subroutine d_vect_reinit - + subroutine d_vect_reall(n, x, info) implicit none @@ -590,16 +614,17 @@ contains end subroutine d_vect_zero - subroutine d_vect_asb(n, x, info) + subroutine d_vect_asb(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch if (allocated(x%v)) then - call x%v%asb(n,info) + call x%v%asb(n,info,scratch=scratch) end if end subroutine d_vect_asb @@ -658,7 +683,7 @@ contains use psi_serial_mod implicit none class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr + 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 @@ -679,7 +704,7 @@ contains use psi_serial_mod implicit none class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: n, maxr class(psb_i_vect_type), intent(inout) :: irl class(psb_d_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/serial/psb_i_base_vect_mod.F90 b/base/modules/serial/psb_i_base_vect_mod.F90 index e2c64af3..5896d32e 100644 --- a/base/modules/serial/psb_i_base_vect_mod.F90 +++ b/base/modules/serial/psb_i_base_vect_mod.F90 @@ -63,6 +63,18 @@ module psb_i_base_vect_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 @@ -86,6 +98,21 @@ module psb_i_base_vect_mod procedure, pass(x) :: asb_e => i_base_asb_e generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => i_base_free + procedure, pass(x) :: reinit => i_base_reinit + procedure, pass(x) :: set_ncfs => i_base_set_ncfs + procedure, pass(x) :: get_ncfs => i_base_get_ncfs + procedure, pass(x) :: set_dupl => i_base_set_dupl + procedure, pass(x) :: get_dupl => i_base_get_dupl + procedure, pass(x) :: set_state => i_base_set_state + procedure, pass(x) :: set_null => i_base_set_null + procedure, pass(x) :: set_bld => i_base_set_bld + procedure, pass(x) :: set_upd => i_base_set_upd + procedure, pass(x) :: set_asb => i_base_set_asb + procedure, pass(x) :: get_state => i_base_get_state + procedure, pass(x) :: is_null => i_base_is_null + procedure, pass(x) :: is_bld => i_base_is_bld + procedure, pass(x) :: is_upd => i_base_is_upd + procedure, pass(x) :: is_asb => i_base_is_asb ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -144,8 +171,6 @@ module psb_i_base_vect_mod - - end type psb_i_base_vect_type public :: psb_i_base_vect @@ -196,14 +221,22 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine i_base_bld_x(x,this) + subroutine i_base_bld_x(x,this,scratch) use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: this(:) class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info integer(psb_ipk_) :: i + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(size(this),x%v,info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') @@ -228,15 +261,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i_base_bld_mn(x,n) + subroutine i_base_bld_mn(x,n,scratch) use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine i_base_bld_mn @@ -245,15 +286,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i_base_bld_en(x,n) + subroutine i_base_bld_en(x,n,scratch) use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine i_base_bld_en @@ -273,9 +322,29 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(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_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 @@ -321,55 +390,116 @@ contains !! \param info return code !! ! - subroutine i_base_ins_a(n,irl,val,dupl,x,info) + subroutine i_base_ins_a(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_i_base_vect_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, 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) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,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 - - 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 + 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_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + 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) + 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 + end if end if call x%set_host() if (info /= 0) then @@ -379,11 +509,11 @@ contains end subroutine i_base_ins_a - subroutine i_base_ins_v(n,irl,val,dupl,x,info) + subroutine i_base_ins_v(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl, maxr class(psb_i_base_vect_type), intent(inout) :: irl class(psb_i_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -396,7 +526,7 @@ contains if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,info) + call x%ins(n,irl%v,val%v,dupl,maxr,info) if (info /= 0) then call psb_errpush(info,'base_vect_ins') @@ -440,19 +570,70 @@ contains !! ! - subroutine i_base_asb_m(n, x, info) + subroutine i_base_asb_m(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_ipk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine i_base_asb_m @@ -470,19 +651,70 @@ contains !! ! - subroutine i_base_asb_e(n, x, info) + subroutine i_base_asb_e(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_ipk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine i_base_asb_e @@ -505,9 +737,10 @@ contains if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + call x%set_null() end subroutine i_base_free @@ -570,7 +803,104 @@ contains if (allocated(x%comid)) & & deallocate(x%comid,stat=info) end subroutine i_base_free_comid + + function i_base_get_ncfs(x) result(res) + implicit none + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function i_base_get_ncfs + + function i_base_get_dupl(x) result(res) + implicit none + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function i_base_get_dupl + + function i_base_get_state(x) result(res) + implicit none + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function i_base_get_state + + function i_base_is_null(x) result(res) + implicit none + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function i_base_is_null + + function i_base_is_bld(x) result(res) + implicit none + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function i_base_is_bld + + function i_base_is_upd(x) result(res) + implicit none + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function i_base_is_upd + + function i_base_is_asb(x) result(res) + implicit none + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function i_base_is_asb + + subroutine i_base_set_ncfs(n,x) + implicit none + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine i_base_set_ncfs + + subroutine i_base_set_dupl(n,x) + implicit none + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine i_base_set_dupl + + subroutine i_base_set_state(n,x) + implicit none + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine i_base_set_state + + subroutine i_base_set_null(x) + implicit none + class(psb_i_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine i_base_set_null + + subroutine i_base_set_bld(x) + implicit none + class(psb_i_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine i_base_set_bld + + subroutine i_base_set_upd(x) + implicit none + class(psb_i_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine i_base_set_upd + + subroutine i_base_set_asb(x) + implicit none + class(psb_i_base_vect_type), intent(inout) :: x + x%bldstate = psb_vect_asb_ + end subroutine i_base_set_asb ! ! The base version of SYNC & friends does nothing, it's just diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 55ed7e9d..6012005c 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -55,14 +55,26 @@ module psb_i_vect_mod procedure, pass(x) :: get_fmt => i_vect_get_fmt procedure, pass(x) :: is_remote_build => i_vect_is_remote_build procedure, pass(x) :: set_remote_build => i_vect_set_remote_build - procedure, pass(x) :: get_dupl => i_vect_get_dupl - procedure, pass(x) :: set_dupl => i_vect_set_dupl procedure, pass(x) :: get_nrmv => i_vect_get_nrmv procedure, pass(x) :: set_nrmv => i_vect_set_nrmv procedure, pass(x) :: all => i_vect_all procedure, pass(x) :: reall => i_vect_reall procedure, pass(x) :: zero => i_vect_zero procedure, pass(x) :: asb => i_vect_asb + procedure, pass(x) :: set_dupl => i_vect_set_dupl + procedure, pass(x) :: get_dupl => i_vect_get_dupl + procedure, pass(x) :: set_state => i_vect_set_state + procedure, pass(x) :: set_null => i_vect_set_null + procedure, pass(x) :: set_bld => i_vect_set_bld + procedure, pass(x) :: set_upd => i_vect_set_upd + procedure, pass(x) :: set_asb => i_vect_set_asb + procedure, pass(x) :: get_state => i_vect_get_state + procedure, pass(x) :: is_null => i_vect_is_null + procedure, pass(x) :: is_bld => i_vect_is_bld + procedure, pass(x) :: is_upd => i_vect_is_upd + procedure, pass(x) :: is_asb => i_vect_is_asb + procedure, pass(x) :: reinit => i_vect_reinit + procedure, pass(x) :: gthab => i_vect_gthab procedure, pass(x) :: gthzv => i_vect_gthzv generic, public :: gth => gthab, gthzv @@ -132,7 +144,11 @@ contains implicit none class(psb_i_vect_type), intent(in) :: x integer(psb_ipk_) :: res - res = x%dupl + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if end function i_vect_get_dupl subroutine i_vect_set_dupl(x,val) @@ -140,13 +156,92 @@ contains class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in), optional :: val - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if end if end subroutine i_vect_set_dupl + function i_vect_get_state(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function i_vect_get_state + + function i_vect_is_null(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function i_vect_is_null + + function i_vect_is_bld(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function i_vect_is_bld + + function i_vect_is_upd(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function i_vect_is_upd + + function i_vect_is_asb(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function i_vect_is_asb + + subroutine i_vect_set_state(n,x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine i_vect_set_state + + + subroutine i_vect_set_null(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine i_vect_set_null + + subroutine i_vect_set_bld(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine i_vect_set_bld + + subroutine i_vect_set_upd(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine i_vect_set_upd + + subroutine i_vect_set_asb(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine i_vect_set_asb + function i_vect_get_nrmv(x) result(res) implicit none class(psb_i_vect_type), intent(in) :: x @@ -236,12 +331,21 @@ contains end if end subroutine i_vect_clone - subroutine i_vect_bld_x(x,invect,mold) + subroutine i_vect_bld_x(x,invect,mold,scratch) integer(psb_ipk_), intent(in) :: invect(:) class(psb_i_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + info = psb_success_ if (allocated(x%v)) & & call x%free(info) @@ -252,17 +356,25 @@ contains allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(invect) + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) end subroutine i_vect_bld_x - subroutine i_vect_bld_mn(x,n,mold) + subroutine i_vect_bld_mn(x,n,mold,scratch) integer(psb_mpk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info class(psb_i_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if info = psb_success_ if (allocated(x%v)) & @@ -273,17 +385,25 @@ contains else allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine i_vect_bld_mn - subroutine i_vect_bld_en(x,n,mold) + subroutine i_vect_bld_en(x,n,mold,scratch) integer(psb_epk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (allocated(x%v)) & & call x%free(info) @@ -293,7 +413,7 @@ contains else allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine i_vect_bld_en @@ -395,8 +515,19 @@ contains else info = psb_err_alloc_dealloc_ end if + call x%set_bld() end subroutine i_vect_all + subroutine i_vect_reinit(x, info) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) call x%v%reinit(info) + call x%set_upd() + + end subroutine i_vect_reinit + subroutine i_vect_reall(n, x, info) implicit none @@ -421,16 +552,17 @@ contains end subroutine i_vect_zero - subroutine i_vect_asb(n, x, info) + subroutine i_vect_asb(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch if (allocated(x%v)) then - call x%v%asb(n,info) + call x%v%asb(n,info,scratch=scratch) end if end subroutine i_vect_asb @@ -485,11 +617,11 @@ contains end subroutine i_vect_free - subroutine i_vect_ins_a(n,irl,val,x,info) + subroutine i_vect_ins_a(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_i_vect_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 @@ -502,15 +634,15 @@ 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_vect_ins_a - subroutine i_vect_ins_v(n,irl,val,x,info) + subroutine i_vect_ins_v(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n, maxr class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -523,7 +655,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl%v,val%v,dupl,info) + call x%v%ins(n,irl%v,val%v,dupl,maxr,info) end subroutine i_vect_ins_v diff --git a/base/modules/serial/psb_l_base_vect_mod.F90 b/base/modules/serial/psb_l_base_vect_mod.F90 index cf30db74..1df397b3 100644 --- a/base/modules/serial/psb_l_base_vect_mod.F90 +++ b/base/modules/serial/psb_l_base_vect_mod.F90 @@ -64,6 +64,18 @@ module psb_l_base_vect_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 @@ -87,6 +99,21 @@ module psb_l_base_vect_mod procedure, pass(x) :: asb_e => l_base_asb_e generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => l_base_free + procedure, pass(x) :: reinit => l_base_reinit + procedure, pass(x) :: set_ncfs => l_base_set_ncfs + procedure, pass(x) :: get_ncfs => l_base_get_ncfs + procedure, pass(x) :: set_dupl => l_base_set_dupl + procedure, pass(x) :: get_dupl => l_base_get_dupl + procedure, pass(x) :: set_state => l_base_set_state + procedure, pass(x) :: set_null => l_base_set_null + procedure, pass(x) :: set_bld => l_base_set_bld + procedure, pass(x) :: set_upd => l_base_set_upd + procedure, pass(x) :: set_asb => l_base_set_asb + procedure, pass(x) :: get_state => l_base_get_state + procedure, pass(x) :: is_null => l_base_is_null + procedure, pass(x) :: is_bld => l_base_is_bld + procedure, pass(x) :: is_upd => l_base_is_upd + procedure, pass(x) :: is_asb => l_base_is_asb ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -145,8 +172,6 @@ module psb_l_base_vect_mod - - end type psb_l_base_vect_type public :: psb_l_base_vect @@ -197,14 +222,22 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine l_base_bld_x(x,this) + subroutine l_base_bld_x(x,this,scratch) use psb_realloc_mod implicit none integer(psb_lpk_), intent(in) :: this(:) class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info integer(psb_ipk_) :: i + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(size(this),x%v,info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') @@ -229,15 +262,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine l_base_bld_mn(x,n) + subroutine l_base_bld_mn(x,n,scratch) use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine l_base_bld_mn @@ -246,15 +287,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine l_base_bld_en(x,n) + subroutine l_base_bld_en(x,n,scratch) use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine l_base_bld_en @@ -274,9 +323,29 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(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_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 @@ -322,55 +391,116 @@ contains !! \param info return code !! ! - subroutine l_base_ins_a(n,irl,val,dupl,x,info) + subroutine l_base_ins_a(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_l_base_vect_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, 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) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,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 - - 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 + 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_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + 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) + 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 + end if end if call x%set_host() if (info /= 0) then @@ -380,11 +510,11 @@ contains end subroutine l_base_ins_a - subroutine l_base_ins_v(n,irl,val,dupl,x,info) + subroutine l_base_ins_v(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl, maxr class(psb_i_base_vect_type), intent(inout) :: irl class(psb_l_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -397,7 +527,7 @@ contains if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,info) + call x%ins(n,irl%v,val%v,dupl,maxr,info) if (info /= 0) then call psb_errpush(info,'base_vect_ins') @@ -441,19 +571,70 @@ contains !! ! - subroutine l_base_asb_m(n, x, info) + subroutine l_base_asb_m(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_lpk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine l_base_asb_m @@ -471,19 +652,70 @@ contains !! ! - subroutine l_base_asb_e(n, x, info) + subroutine l_base_asb_e(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_lpk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine l_base_asb_e @@ -506,9 +738,10 @@ contains if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + call x%set_null() end subroutine l_base_free @@ -571,7 +804,104 @@ contains if (allocated(x%comid)) & & deallocate(x%comid,stat=info) end subroutine l_base_free_comid + + function l_base_get_ncfs(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function l_base_get_ncfs + + function l_base_get_dupl(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function l_base_get_dupl + + function l_base_get_state(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function l_base_get_state + + function l_base_is_null(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function l_base_is_null + + function l_base_is_bld(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function l_base_is_bld + + function l_base_is_upd(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function l_base_is_upd + + function l_base_is_asb(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function l_base_is_asb + + subroutine l_base_set_ncfs(n,x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine l_base_set_ncfs + + subroutine l_base_set_dupl(n,x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine l_base_set_dupl + + subroutine l_base_set_state(n,x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine l_base_set_state + + subroutine l_base_set_null(x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine l_base_set_null + + subroutine l_base_set_bld(x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine l_base_set_bld + + subroutine l_base_set_upd(x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine l_base_set_upd + + subroutine l_base_set_asb(x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + x%bldstate = psb_vect_asb_ + end subroutine l_base_set_asb ! ! The base version of SYNC & friends does nothing, it's just diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index 6936e75f..d9a91d11 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -56,14 +56,26 @@ module psb_l_vect_mod procedure, pass(x) :: get_fmt => l_vect_get_fmt procedure, pass(x) :: is_remote_build => l_vect_is_remote_build procedure, pass(x) :: set_remote_build => l_vect_set_remote_build - procedure, pass(x) :: get_dupl => l_vect_get_dupl - procedure, pass(x) :: set_dupl => l_vect_set_dupl procedure, pass(x) :: get_nrmv => l_vect_get_nrmv procedure, pass(x) :: set_nrmv => l_vect_set_nrmv procedure, pass(x) :: all => l_vect_all procedure, pass(x) :: reall => l_vect_reall procedure, pass(x) :: zero => l_vect_zero procedure, pass(x) :: asb => l_vect_asb + procedure, pass(x) :: set_dupl => l_vect_set_dupl + procedure, pass(x) :: get_dupl => l_vect_get_dupl + procedure, pass(x) :: set_state => l_vect_set_state + procedure, pass(x) :: set_null => l_vect_set_null + procedure, pass(x) :: set_bld => l_vect_set_bld + procedure, pass(x) :: set_upd => l_vect_set_upd + procedure, pass(x) :: set_asb => l_vect_set_asb + procedure, pass(x) :: get_state => l_vect_get_state + procedure, pass(x) :: is_null => l_vect_is_null + procedure, pass(x) :: is_bld => l_vect_is_bld + procedure, pass(x) :: is_upd => l_vect_is_upd + procedure, pass(x) :: is_asb => l_vect_is_asb + procedure, pass(x) :: reinit => l_vect_reinit + procedure, pass(x) :: gthab => l_vect_gthab procedure, pass(x) :: gthzv => l_vect_gthzv generic, public :: gth => gthab, gthzv @@ -133,7 +145,11 @@ contains implicit none class(psb_l_vect_type), intent(in) :: x integer(psb_ipk_) :: res - res = x%dupl + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if end function l_vect_get_dupl subroutine l_vect_set_dupl(x,val) @@ -141,13 +157,92 @@ contains class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in), optional :: val - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if end if end subroutine l_vect_set_dupl + function l_vect_get_state(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function l_vect_get_state + + function l_vect_is_null(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function l_vect_is_null + + function l_vect_is_bld(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function l_vect_is_bld + + function l_vect_is_upd(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function l_vect_is_upd + + function l_vect_is_asb(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function l_vect_is_asb + + subroutine l_vect_set_state(n,x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine l_vect_set_state + + + subroutine l_vect_set_null(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine l_vect_set_null + + subroutine l_vect_set_bld(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine l_vect_set_bld + + subroutine l_vect_set_upd(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine l_vect_set_upd + + subroutine l_vect_set_asb(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine l_vect_set_asb + function l_vect_get_nrmv(x) result(res) implicit none class(psb_l_vect_type), intent(in) :: x @@ -237,12 +332,21 @@ contains end if end subroutine l_vect_clone - subroutine l_vect_bld_x(x,invect,mold) + subroutine l_vect_bld_x(x,invect,mold,scratch) integer(psb_lpk_), intent(in) :: invect(:) class(psb_l_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + info = psb_success_ if (allocated(x%v)) & & call x%free(info) @@ -253,17 +357,25 @@ contains allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(invect) + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) end subroutine l_vect_bld_x - subroutine l_vect_bld_mn(x,n,mold) + subroutine l_vect_bld_mn(x,n,mold,scratch) integer(psb_mpk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info class(psb_l_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if info = psb_success_ if (allocated(x%v)) & @@ -274,17 +386,25 @@ contains else allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine l_vect_bld_mn - subroutine l_vect_bld_en(x,n,mold) + subroutine l_vect_bld_en(x,n,mold,scratch) integer(psb_epk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (allocated(x%v)) & & call x%free(info) @@ -294,7 +414,7 @@ contains else allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine l_vect_bld_en @@ -396,8 +516,19 @@ contains else info = psb_err_alloc_dealloc_ end if + call x%set_bld() end subroutine l_vect_all + subroutine l_vect_reinit(x, info) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) call x%v%reinit(info) + call x%set_upd() + + end subroutine l_vect_reinit + subroutine l_vect_reall(n, x, info) implicit none @@ -422,16 +553,17 @@ contains end subroutine l_vect_zero - subroutine l_vect_asb(n, x, info) + subroutine l_vect_asb(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch if (allocated(x%v)) then - call x%v%asb(n,info) + call x%v%asb(n,info,scratch=scratch) end if end subroutine l_vect_asb @@ -486,11 +618,11 @@ contains end subroutine l_vect_free - subroutine l_vect_ins_a(n,irl,val,x,info) + subroutine l_vect_ins_a(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_l_vect_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 @@ -503,15 +635,15 @@ 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_vect_ins_a - subroutine l_vect_ins_v(n,irl,val,x,info) + subroutine l_vect_ins_v(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n, maxr class(psb_i_vect_type), intent(inout) :: irl class(psb_l_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -524,7 +656,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl%v,val%v,dupl,info) + call x%v%ins(n,irl%v,val%v,dupl,maxr,info) end subroutine l_vect_ins_v diff --git a/base/modules/serial/psb_s_base_vect_mod.F90 b/base/modules/serial/psb_s_base_vect_mod.F90 index 702a1af3..488bfbe2 100644 --- a/base/modules/serial/psb_s_base_vect_mod.F90 +++ b/base/modules/serial/psb_s_base_vect_mod.F90 @@ -65,6 +65,18 @@ module psb_s_base_vect_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 @@ -88,6 +100,21 @@ module psb_s_base_vect_mod procedure, pass(x) :: asb_e => s_base_asb_e generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => s_base_free + procedure, pass(x) :: reinit => s_base_reinit + procedure, pass(x) :: set_ncfs => s_base_set_ncfs + procedure, pass(x) :: get_ncfs => s_base_get_ncfs + procedure, pass(x) :: set_dupl => s_base_set_dupl + procedure, pass(x) :: get_dupl => s_base_get_dupl + procedure, pass(x) :: set_state => s_base_set_state + procedure, pass(x) :: set_null => s_base_set_null + procedure, pass(x) :: set_bld => s_base_set_bld + procedure, pass(x) :: set_upd => s_base_set_upd + procedure, pass(x) :: set_asb => s_base_set_asb + procedure, pass(x) :: get_state => s_base_get_state + procedure, pass(x) :: is_null => s_base_is_null + procedure, pass(x) :: is_bld => s_base_is_bld + procedure, pass(x) :: is_upd => s_base_is_upd + procedure, pass(x) :: is_asb => s_base_is_asb ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -218,8 +245,6 @@ module psb_s_base_vect_mod procedure, pass(x) :: minquotient_a2 => s_base_minquotient_a2 generic, public :: minquotient => minquotient_v, minquotient_a2 - - end type psb_s_base_vect_type public :: psb_s_base_vect @@ -270,14 +295,22 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine s_base_bld_x(x,this) + subroutine s_base_bld_x(x,this,scratch) use psb_realloc_mod implicit none real(psb_spk_), intent(in) :: this(:) class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info integer(psb_ipk_) :: i + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(size(this),x%v,info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') @@ -302,15 +335,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine s_base_bld_mn(x,n) + subroutine s_base_bld_mn(x,n,scratch) use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine s_base_bld_mn @@ -319,15 +360,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine s_base_bld_en(x,n) + subroutine s_base_bld_en(x,n,scratch) use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine s_base_bld_en @@ -347,9 +396,29 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(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_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 @@ -395,55 +464,116 @@ contains !! \param info return code !! ! - subroutine s_base_ins_a(n,irl,val,dupl,x,info) + subroutine s_base_ins_a(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_s_base_vect_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, 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) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,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 - ! 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 + 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)) = x%v(irl(i)) + val(i) + x%v(k) = val(i) + x%iv(k) = irl(i) 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_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + 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_ - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + else + isz = size(x%v) + 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 + end if end if call x%set_host() if (info /= 0) then @@ -453,11 +583,11 @@ contains end subroutine s_base_ins_a - subroutine s_base_ins_v(n,irl,val,dupl,x,info) + subroutine s_base_ins_v(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl, maxr class(psb_i_base_vect_type), intent(inout) :: irl class(psb_s_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -470,7 +600,7 @@ contains if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,info) + call x%ins(n,irl%v,val%v,dupl,maxr,info) if (info /= 0) then call psb_errpush(info,'base_vect_ins') @@ -514,19 +644,70 @@ contains !! ! - subroutine s_base_asb_m(n, x, info) + subroutine s_base_asb_m(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + real(psb_spk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine s_base_asb_m @@ -544,19 +725,70 @@ contains !! ! - subroutine s_base_asb_e(n, x, info) + subroutine s_base_asb_e(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + real(psb_spk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine s_base_asb_e @@ -579,9 +811,10 @@ contains if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + call x%set_null() end subroutine s_base_free @@ -644,7 +877,104 @@ contains if (allocated(x%comid)) & & deallocate(x%comid,stat=info) end subroutine s_base_free_comid + + function s_base_get_ncfs(x) result(res) + implicit none + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function s_base_get_ncfs + + function s_base_get_dupl(x) result(res) + implicit none + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function s_base_get_dupl + + function s_base_get_state(x) result(res) + implicit none + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function s_base_get_state + + function s_base_is_null(x) result(res) + implicit none + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function s_base_is_null + + function s_base_is_bld(x) result(res) + implicit none + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function s_base_is_bld + + function s_base_is_upd(x) result(res) + implicit none + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function s_base_is_upd + + function s_base_is_asb(x) result(res) + implicit none + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function s_base_is_asb + + subroutine s_base_set_ncfs(n,x) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine s_base_set_ncfs + + subroutine s_base_set_dupl(n,x) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine s_base_set_dupl + + subroutine s_base_set_state(n,x) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine s_base_set_state + + subroutine s_base_set_null(x) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine s_base_set_null + + subroutine s_base_set_bld(x) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine s_base_set_bld + + subroutine s_base_set_upd(x) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine s_base_set_upd + + subroutine s_base_set_asb(x) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + x%bldstate = psb_vect_asb_ + end subroutine s_base_set_asb ! ! The base version of SYNC & friends does nothing, it's just diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 3e27495a..ddb5590b 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -56,14 +56,26 @@ module psb_s_vect_mod procedure, pass(x) :: get_fmt => s_vect_get_fmt procedure, pass(x) :: is_remote_build => s_vect_is_remote_build procedure, pass(x) :: set_remote_build => s_vect_set_remote_build - procedure, pass(x) :: get_dupl => s_vect_get_dupl - procedure, pass(x) :: set_dupl => s_vect_set_dupl procedure, pass(x) :: get_nrmv => s_vect_get_nrmv procedure, pass(x) :: set_nrmv => s_vect_set_nrmv procedure, pass(x) :: all => s_vect_all procedure, pass(x) :: reall => s_vect_reall procedure, pass(x) :: zero => s_vect_zero procedure, pass(x) :: asb => s_vect_asb + procedure, pass(x) :: set_dupl => s_vect_set_dupl + procedure, pass(x) :: get_dupl => s_vect_get_dupl + procedure, pass(x) :: set_state => s_vect_set_state + procedure, pass(x) :: set_null => s_vect_set_null + procedure, pass(x) :: set_bld => s_vect_set_bld + procedure, pass(x) :: set_upd => s_vect_set_upd + procedure, pass(x) :: set_asb => s_vect_set_asb + procedure, pass(x) :: get_state => s_vect_get_state + procedure, pass(x) :: is_null => s_vect_is_null + procedure, pass(x) :: is_bld => s_vect_is_bld + procedure, pass(x) :: is_upd => s_vect_is_upd + procedure, pass(x) :: is_asb => s_vect_is_asb + procedure, pass(x) :: reinit => s_vect_reinit + procedure, pass(x) :: gthab => s_vect_gthab procedure, pass(x) :: gthzv => s_vect_gthzv generic, public :: gth => gthab, gthzv @@ -194,7 +206,11 @@ contains implicit none class(psb_s_vect_type), intent(in) :: x integer(psb_ipk_) :: res - res = x%dupl + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if end function s_vect_get_dupl subroutine s_vect_set_dupl(x,val) @@ -202,13 +218,92 @@ contains class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in), optional :: val - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if end if end subroutine s_vect_set_dupl + function s_vect_get_state(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function s_vect_get_state + + function s_vect_is_null(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function s_vect_is_null + + function s_vect_is_bld(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function s_vect_is_bld + + function s_vect_is_upd(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function s_vect_is_upd + + function s_vect_is_asb(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function s_vect_is_asb + + subroutine s_vect_set_state(n,x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine s_vect_set_state + + + subroutine s_vect_set_null(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine s_vect_set_null + + subroutine s_vect_set_bld(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine s_vect_set_bld + + subroutine s_vect_set_upd(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine s_vect_set_upd + + subroutine s_vect_set_asb(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine s_vect_set_asb + function s_vect_get_nrmv(x) result(res) implicit none class(psb_s_vect_type), intent(in) :: x @@ -298,12 +393,21 @@ contains end if end subroutine s_vect_clone - subroutine s_vect_bld_x(x,invect,mold) + subroutine s_vect_bld_x(x,invect,mold,scratch) real(psb_spk_), intent(in) :: invect(:) class(psb_s_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + info = psb_success_ if (allocated(x%v)) & & call x%free(info) @@ -314,17 +418,25 @@ contains allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(invect) + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) end subroutine s_vect_bld_x - subroutine s_vect_bld_mn(x,n,mold) + subroutine s_vect_bld_mn(x,n,mold,scratch) integer(psb_mpk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info class(psb_s_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if info = psb_success_ if (allocated(x%v)) & @@ -335,17 +447,25 @@ contains else allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine s_vect_bld_mn - subroutine s_vect_bld_en(x,n,mold) + subroutine s_vect_bld_en(x,n,mold,scratch) integer(psb_epk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (allocated(x%v)) & & call x%free(info) @@ -355,7 +475,7 @@ contains else allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine s_vect_bld_en @@ -457,8 +577,19 @@ contains else info = psb_err_alloc_dealloc_ end if + call x%set_bld() end subroutine s_vect_all + subroutine s_vect_reinit(x, info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) call x%v%reinit(info) + call x%set_upd() + + end subroutine s_vect_reinit + subroutine s_vect_reall(n, x, info) implicit none @@ -483,16 +614,17 @@ contains end subroutine s_vect_zero - subroutine s_vect_asb(n, x, info) + subroutine s_vect_asb(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch if (allocated(x%v)) then - call x%v%asb(n,info) + call x%v%asb(n,info,scratch=scratch) end if end subroutine s_vect_asb @@ -547,11 +679,11 @@ contains end subroutine s_vect_free - subroutine s_vect_ins_a(n,irl,val,x,info) + subroutine s_vect_ins_a(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_s_vect_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 @@ -564,15 +696,15 @@ 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_vect_ins_a - subroutine s_vect_ins_v(n,irl,val,x,info) + subroutine s_vect_ins_v(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n, maxr class(psb_i_vect_type), intent(inout) :: irl class(psb_s_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -585,7 +717,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl%v,val%v,dupl,info) + call x%v%ins(n,irl%v,val%v,dupl,maxr,info) end subroutine s_vect_ins_v diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index bf1a276c..fa7fb39a 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -65,6 +65,18 @@ module psb_z_base_vect_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 @@ -88,6 +100,21 @@ module psb_z_base_vect_mod procedure, pass(x) :: asb_e => z_base_asb_e generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => z_base_free + procedure, pass(x) :: reinit => z_base_reinit + procedure, pass(x) :: set_ncfs => z_base_set_ncfs + procedure, pass(x) :: get_ncfs => z_base_get_ncfs + procedure, pass(x) :: set_dupl => z_base_set_dupl + procedure, pass(x) :: get_dupl => z_base_get_dupl + procedure, pass(x) :: set_state => z_base_set_state + procedure, pass(x) :: set_null => z_base_set_null + procedure, pass(x) :: set_bld => z_base_set_bld + procedure, pass(x) :: set_upd => z_base_set_upd + procedure, pass(x) :: set_asb => z_base_set_asb + procedure, pass(x) :: get_state => z_base_get_state + procedure, pass(x) :: is_null => z_base_is_null + procedure, pass(x) :: is_bld => z_base_is_bld + procedure, pass(x) :: is_upd => z_base_is_upd + procedure, pass(x) :: is_asb => z_base_is_asb ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -211,8 +238,6 @@ module psb_z_base_vect_mod generic, public :: addconst => addconst_a2,addconst_v2 - - end type psb_z_base_vect_type public :: psb_z_base_vect @@ -263,14 +288,22 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine z_base_bld_x(x,this) + subroutine z_base_bld_x(x,this,scratch) use psb_realloc_mod implicit none complex(psb_dpk_), intent(in) :: this(:) class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info integer(psb_ipk_) :: i + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(size(this),x%v,info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') @@ -295,15 +328,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine z_base_bld_mn(x,n) + subroutine z_base_bld_mn(x,n,scratch) use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine z_base_bld_mn @@ -312,15 +353,23 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine z_base_bld_en(x,n) + subroutine z_base_bld_en(x,n,scratch) use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(n,x%v,info) - call x%asb(n,info) + call x%asb(n,info,scratch=scratch_) end subroutine z_base_bld_en @@ -340,9 +389,29 @@ contains integer(psb_ipk_), intent(out) :: info call psb_realloc(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_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 @@ -388,55 +457,116 @@ contains !! \param info return code !! ! - subroutine z_base_ins_a(n,irl,val,dupl,x,info) + subroutine z_base_ins_a(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_z_base_vect_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, 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) - select case(dupl) - case(psb_dupl_ovwrt_) + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,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 - ! 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 + 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)) = x%v(irl(i)) + val(i) + x%v(k) = val(i) + x%iv(k) = irl(i) 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_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + 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_ - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select + else + isz = size(x%v) + 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 + end if end if call x%set_host() if (info /= 0) then @@ -446,11 +576,11 @@ contains end subroutine z_base_ins_a - subroutine z_base_ins_v(n,irl,val,dupl,x,info) + subroutine z_base_ins_v(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl, maxr class(psb_i_base_vect_type), intent(inout) :: irl class(psb_z_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -463,7 +593,7 @@ contains if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,info) + call x%ins(n,irl%v,val%v,dupl,maxr,info) if (info /= 0) then call psb_errpush(info,'base_vect_ins') @@ -507,19 +637,70 @@ contains !! ! - subroutine z_base_asb_m(n, x, info) + subroutine z_base_asb_m(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_dpk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine z_base_asb_m @@ -537,19 +718,70 @@ contains !! ! - subroutine z_base_asb_e(n, x, info) + subroutine z_base_asb_e(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_epk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_dpk_), allocatable :: vv(:) info = 0 - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne.dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if call x%sync() end subroutine z_base_asb_e @@ -572,9 +804,10 @@ contains if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + call x%set_null() end subroutine z_base_free @@ -637,7 +870,104 @@ contains if (allocated(x%comid)) & & deallocate(x%comid,stat=info) end subroutine z_base_free_comid + + function z_base_get_ncfs(x) result(res) + implicit none + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function z_base_get_ncfs + + function z_base_get_dupl(x) result(res) + implicit none + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function z_base_get_dupl + + function z_base_get_state(x) result(res) + implicit none + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function z_base_get_state + + function z_base_is_null(x) result(res) + implicit none + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function z_base_is_null + + function z_base_is_bld(x) result(res) + implicit none + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function z_base_is_bld + + function z_base_is_upd(x) result(res) + implicit none + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function z_base_is_upd + + function z_base_is_asb(x) result(res) + implicit none + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function z_base_is_asb + + subroutine z_base_set_ncfs(n,x) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine z_base_set_ncfs + + subroutine z_base_set_dupl(n,x) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine z_base_set_dupl + + subroutine z_base_set_state(n,x) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine z_base_set_state + + subroutine z_base_set_null(x) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine z_base_set_null + + subroutine z_base_set_bld(x) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine z_base_set_bld + + subroutine z_base_set_upd(x) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine z_base_set_upd + + subroutine z_base_set_asb(x) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + x%bldstate = psb_vect_asb_ + end subroutine z_base_set_asb ! ! The base version of SYNC & friends does nothing, it's just diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 79606f3b..8f593d0e 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -56,14 +56,26 @@ module psb_z_vect_mod procedure, pass(x) :: get_fmt => z_vect_get_fmt procedure, pass(x) :: is_remote_build => z_vect_is_remote_build procedure, pass(x) :: set_remote_build => z_vect_set_remote_build - procedure, pass(x) :: get_dupl => z_vect_get_dupl - procedure, pass(x) :: set_dupl => z_vect_set_dupl procedure, pass(x) :: get_nrmv => z_vect_get_nrmv procedure, pass(x) :: set_nrmv => z_vect_set_nrmv procedure, pass(x) :: all => z_vect_all procedure, pass(x) :: reall => z_vect_reall procedure, pass(x) :: zero => z_vect_zero procedure, pass(x) :: asb => z_vect_asb + procedure, pass(x) :: set_dupl => z_vect_set_dupl + procedure, pass(x) :: get_dupl => z_vect_get_dupl + procedure, pass(x) :: set_state => z_vect_set_state + procedure, pass(x) :: set_null => z_vect_set_null + procedure, pass(x) :: set_bld => z_vect_set_bld + procedure, pass(x) :: set_upd => z_vect_set_upd + procedure, pass(x) :: set_asb => z_vect_set_asb + procedure, pass(x) :: get_state => z_vect_get_state + procedure, pass(x) :: is_null => z_vect_is_null + procedure, pass(x) :: is_bld => z_vect_is_bld + procedure, pass(x) :: is_upd => z_vect_is_upd + procedure, pass(x) :: is_asb => z_vect_is_asb + procedure, pass(x) :: reinit => z_vect_reinit + procedure, pass(x) :: gthab => z_vect_gthab procedure, pass(x) :: gthzv => z_vect_gthzv generic, public :: gth => gthab, gthzv @@ -187,7 +199,11 @@ contains implicit none class(psb_z_vect_type), intent(in) :: x integer(psb_ipk_) :: res - res = x%dupl + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if end function z_vect_get_dupl subroutine z_vect_set_dupl(x,val) @@ -195,13 +211,92 @@ contains class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in), optional :: val - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if end if end subroutine z_vect_set_dupl + function z_vect_get_state(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function z_vect_get_state + + function z_vect_is_null(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function z_vect_is_null + + function z_vect_is_bld(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function z_vect_is_bld + + function z_vect_is_upd(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function z_vect_is_upd + + function z_vect_is_asb(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function z_vect_is_asb + + subroutine z_vect_set_state(n,x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine z_vect_set_state + + + subroutine z_vect_set_null(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine z_vect_set_null + + subroutine z_vect_set_bld(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine z_vect_set_bld + + subroutine z_vect_set_upd(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine z_vect_set_upd + + subroutine z_vect_set_asb(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine z_vect_set_asb + function z_vect_get_nrmv(x) result(res) implicit none class(psb_z_vect_type), intent(in) :: x @@ -291,12 +386,21 @@ contains end if end subroutine z_vect_clone - subroutine z_vect_bld_x(x,invect,mold) + subroutine z_vect_bld_x(x,invect,mold,scratch) complex(psb_dpk_), intent(in) :: invect(:) class(psb_z_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + info = psb_success_ if (allocated(x%v)) & & call x%free(info) @@ -307,17 +411,25 @@ contains allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(invect) + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) end subroutine z_vect_bld_x - subroutine z_vect_bld_mn(x,n,mold) + subroutine z_vect_bld_mn(x,n,mold,scratch) integer(psb_mpk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info class(psb_z_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if info = psb_success_ if (allocated(x%v)) & @@ -328,17 +440,25 @@ contains else allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine z_vect_bld_mn - subroutine z_vect_bld_en(x,n,mold) + subroutine z_vect_bld_en(x,n,mold,scratch) integer(psb_epk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (allocated(x%v)) & & call x%free(info) @@ -348,7 +468,7 @@ contains else allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) endif - if (info == psb_success_) call x%v%bld(n) + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) end subroutine z_vect_bld_en @@ -450,8 +570,19 @@ contains else info = psb_err_alloc_dealloc_ end if + call x%set_bld() end subroutine z_vect_all + subroutine z_vect_reinit(x, info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) call x%v%reinit(info) + call x%set_upd() + + end subroutine z_vect_reinit + subroutine z_vect_reall(n, x, info) implicit none @@ -476,16 +607,17 @@ contains end subroutine z_vect_zero - subroutine z_vect_asb(n, x, info) + subroutine z_vect_asb(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch if (allocated(x%v)) then - call x%v%asb(n,info) + call x%v%asb(n,info,scratch=scratch) end if end subroutine z_vect_asb @@ -540,11 +672,11 @@ contains end subroutine z_vect_free - subroutine z_vect_ins_a(n,irl,val,x,info) + subroutine z_vect_ins_a(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_z_vect_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 @@ -557,15 +689,15 @@ 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_vect_ins_a - subroutine z_vect_ins_v(n,irl,val,x,info) + subroutine z_vect_ins_v(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n, maxr class(psb_i_vect_type), intent(inout) :: irl class(psb_z_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -578,7 +710,7 @@ contains return end if dupl = x%get_dupl() - call x%v%ins(n,irl%v,val%v,dupl,info) + call x%v%ins(n,irl%v,val%v,dupl,maxr,info) end subroutine z_vect_ins_v diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index 97ee169f..cb39593f 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -70,7 +70,7 @@ Module psb_c_tools_mod interface psb_geasb - subroutine psb_casb_vect(x, desc_a, info,mold, scratch) + subroutine psb_casb_vect(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -78,6 +78,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 subroutine psb_casb_vect_r2(x, desc_a, info,mold, scratch) import @@ -250,13 +251,14 @@ Module psb_c_tools_mod end interface interface psb_spasb - subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and) + subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) import implicit none type(psb_cspmat_type), intent (inout) :: a type(psb_desc_type), intent(inout) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_),optional, intent(in) :: upd + integer(psb_ipk_),optional, intent(in) :: dupl character(len=*), optional, intent(in) :: afmt class(psb_c_base_sparse_mat), intent(in), optional :: mold logical, intent(in), optional :: bld_and diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index 2d583317..da305164 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -257,11 +257,11 @@ Module psb_d_tools_mod type(psb_dspmat_type), intent (inout) :: a type(psb_desc_type), intent(inout) :: desc_a integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: upd + integer(psb_ipk_),optional, intent(in) :: upd + integer(psb_ipk_),optional, intent(in) :: dupl character(len=*), optional, intent(in) :: afmt class(psb_d_base_sparse_mat), intent(in), optional :: mold logical, intent(in), optional :: bld_and - integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_dspasb end interface diff --git a/base/modules/tools/psb_i_tools_mod.F90 b/base/modules/tools/psb_i_tools_mod.F90 index 1c207fac..f0ccfb72 100644 --- a/base/modules/tools/psb_i_tools_mod.F90 +++ b/base/modules/tools/psb_i_tools_mod.F90 @@ -69,7 +69,7 @@ Module psb_i_tools_mod interface psb_geasb - subroutine psb_iasb_vect(x, desc_a, info,mold, scratch) + subroutine psb_iasb_vect(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -77,6 +77,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 subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch) import diff --git a/base/modules/tools/psb_l_tools_mod.F90 b/base/modules/tools/psb_l_tools_mod.F90 index 058403d6..56cdddcb 100644 --- a/base/modules/tools/psb_l_tools_mod.F90 +++ b/base/modules/tools/psb_l_tools_mod.F90 @@ -69,7 +69,7 @@ Module psb_l_tools_mod interface psb_geasb - subroutine psb_lasb_vect(x, desc_a, info,mold, scratch) + subroutine psb_lasb_vect(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -77,6 +77,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 subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch) import diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index 18addeda..f6e97208 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -70,7 +70,7 @@ Module psb_s_tools_mod interface psb_geasb - subroutine psb_sasb_vect(x, desc_a, info,mold, scratch) + subroutine psb_sasb_vect(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -78,6 +78,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 subroutine psb_sasb_vect_r2(x, desc_a, info,mold, scratch) import @@ -250,13 +251,14 @@ Module psb_s_tools_mod end interface interface psb_spasb - subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and) + subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) import implicit none type(psb_sspmat_type), intent (inout) :: a type(psb_desc_type), intent(inout) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_),optional, intent(in) :: upd + integer(psb_ipk_),optional, intent(in) :: dupl character(len=*), optional, intent(in) :: afmt class(psb_s_base_sparse_mat), intent(in), optional :: mold logical, intent(in), optional :: bld_and diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index fd9d5e22..f0e42c75 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -70,7 +70,7 @@ Module psb_z_tools_mod interface psb_geasb - subroutine psb_zasb_vect(x, desc_a, info,mold, scratch) + subroutine psb_zasb_vect(x, desc_a, info,mold, scratch,dupl) import implicit none type(psb_desc_type), intent(in) :: desc_a @@ -78,6 +78,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 subroutine psb_zasb_vect_r2(x, desc_a, info,mold, scratch) import @@ -250,13 +251,14 @@ Module psb_z_tools_mod end interface interface psb_spasb - subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and) + subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) import implicit none type(psb_zspmat_type), intent (inout) :: a type(psb_desc_type), intent(inout) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_),optional, intent(in) :: upd + integer(psb_ipk_),optional, intent(in) :: dupl character(len=*), optional, intent(in) :: afmt class(psb_z_base_sparse_mat), intent(in), optional :: mold logical, intent(in), optional :: bld_and diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index 82348a78..9c31332b 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -109,12 +109,10 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode) else bldmode_ = psb_matbld_noremote_ end if + call x%set_bld() if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - call x%set_dupl(dupl_) + call x%set_dupl(dupl) + end if call x%set_remote_build(bldmode_) call x%set_nrmv(izero) if (x%is_remote_build()) then diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index 83e2715b..ad6e69d3 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -51,7 +51,7 @@ ! scratch - logical, optional If true, allocate without checking/zeroing contents. ! default: .false. ! -subroutine psb_casb_vect(x, desc_a, info, mold, scratch) +subroutine psb_casb_vect(x, desc_a, info, mold, scratch, dupl) use psb_base_mod, psb_protect_name => psb_casb_vect implicit none @@ -60,6 +60,7 @@ subroutine psb_casb_vect(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 @@ -80,10 +81,9 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. + scratch_ = .false. if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) - dupl_ = x%get_dupl() ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -100,39 +100,83 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - if (scratch_) then - call x%free(info) - call x%bld(ncol,mold=mold) + dupl_ = x%get_dupl() + if (try_newins) then + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold,scratch=scratch_) + else + if (x%is_bld().and.present(dupl)) then + call x%set_dupl(dupl) + dupl_ = dupl + end if + + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + complex(psb_spk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' else - if (x%is_remote_build()) then - block - integer(psb_lpk_), allocatable :: lvx(:) - complex(psb_spk_), allocatable :: vx(:) - integer(psb_ipk_), allocatable :: ivx(:) - integer(psb_ipk_) :: nrmv, nx, i - - nrmv = x%get_nrmv() - call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) - nx = size(vx) - call psb_realloc(nx,ivx,info) - call desc_a%g2l(lvx,ivx,info,owned=.true.) - call x%ins(nx,ivx,vx,info) - end block - end if - - call x%asb(ncol,info) - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold) + else + if (x%is_bld().and.present(dupl)) then + dupl_ = dupl + end if + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + complex(psb_spk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) end if - call x%cnv(mold) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' call psb_erractionrestore(err_act) return @@ -202,7 +246,7 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) else do i=1, n dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info) + call x(i)%asb(ncol,info,scratch=scratch) if (info /= 0) exit ! ..update halo elements.. call psb_halo(x(i),desc_a,info) diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index 180520a3..ee0391a1 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -57,7 +57,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_ipk_) :: i, loc_rows, loc_cols integer(psb_lpk_) :: mglob integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt @@ -127,7 +127,7 @@ subroutine psb_cins_vect(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 @@ -198,7 +198,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act integer(psb_lpk_) :: mglob type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me @@ -261,7 +261,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,lval,info) + call x%ins(m,irl,lval,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -368,7 +368,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, local) do i=1,n if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ - if (info == 0) call x(i)%ins(m,irl,val(:,i),info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info) if (info /= 0) exit end do if (info /= 0) then diff --git a/base/tools/psb_cspasb.f90 b/base/tools/psb_cspasb.f90 index db8af75a..1ada38e9 100644 --- a/base/tools/psb_cspasb.f90 +++ b/base/tools/psb_cspasb.f90 @@ -44,7 +44,7 @@ ! psb_upd_perm_ Permutation(more memory) ! ! -subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and) +subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) use psb_base_mod, psb_protect_name => psb_cspasb use psb_sort_mod use psi_mod @@ -59,6 +59,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and) character(len=*), optional, intent(in) :: afmt class(psb_c_base_sparse_mat), intent(in), optional :: mold logical, intent(in), optional :: bld_and + integer(psb_ipk_), optional, intent(in) :: dupl !....Locals.... type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, err_act @@ -103,7 +104,12 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and) !check on errors encountered in psdspins if (a%is_bld()) then - dupl_ = a%get_dupl() + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = a%get_dupl() + end if + ! ! First case: we come from a fresh build. ! @@ -180,7 +186,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and) if (bld_and_) then !!$ allocate(a%ad,mold=a%a) !!$ allocate(a%and,mold=a%a)o - call a%split_nd(n_row,n_col,info) +!!$ call a%split_nd(n_row,n_col,info) !!$ block !!$ character(len=1024) :: fname !!$ type(psb_c_coo_sparse_mat) :: acoo diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 45116e07..52c0ae90 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -109,13 +109,10 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode) else bldmode_ = psb_matbld_noremote_ end if - if (present(dupl)) then - dupl_ = dupl -!!$ else -!!$ dupl_ = psb_dupl_def_ - end if -!!$ call x%set_dupl(dupl_) call x%set_bld() + if (present(dupl)) then + call x%set_dupl(dupl) + end if call x%set_remote_build(bldmode_) call x%set_nrmv(izero) if (x%is_remote_build()) then diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index ead3d1d0..eb15dc1a 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -51,7 +51,7 @@ ! scratch - logical, optional If true, allocate without checking/zeroing contents. ! default: .false. ! -subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) +subroutine psb_dasb_vect(x, desc_a, info, mold, scratch, dupl) use psb_base_mod, psb_protect_name => psb_dasb_vect implicit none @@ -69,7 +69,6 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err - !logical, parameter :: try_newins = .true. info = psb_success_ name = 'psb_dgeasb_v' @@ -82,7 +81,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. + scratch_ = .false. if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. @@ -95,32 +94,30 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) call psb_errpush(info,name) goto 9999 end if - + nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - if (try_newins) then -!!$ if (present(dupl)) then -!!$ call x%set_dupl(dupl) -!!$ end if - dupl_ = x%get_dupl() + dupl_ = x%get_dupl() + if (try_newins) then if (scratch_) then call x%free(info) - call x%bld(ncol,mold=mold) + call x%bld(ncol,mold=mold,scratch=scratch_) else if (x%is_bld().and.present(dupl)) then - call x%set_dupl(dupl) + call x%set_dupl(dupl) dupl_ = dupl end if + if (x%is_remote_build()) then block integer(psb_lpk_), allocatable :: lvx(:) real(psb_dpk_), allocatable :: vx(:) integer(psb_ipk_), allocatable :: ivx(:) integer(psb_ipk_) :: nrmv, nx, i - + nrmv = x%get_nrmv() call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) nx = size(vx) @@ -129,8 +126,8 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) call x%ins(nx,ivx,vx,nrow,info) end block end if - - call x%asb(ncol,info) + + call x%asb(ncol,info,scratch=scratch) ! ..update halo elements.. call psb_halo(x,desc_a,info) if(info /= psb_success_) then @@ -143,14 +140,12 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' else - dupl_ = x%get_dupl() - + if (scratch_) then call x%free(info) call x%bld(ncol,mold=mold) else if (x%is_bld().and.present(dupl)) then -!!$ call x%set_dupl(dupl) dupl_ = dupl end if if (x%is_remote_build()) then @@ -169,7 +164,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) end block end if - call x%asb(ncol,info) + call x%asb(ncol,info,scratch=scratch) ! ..update halo elements.. call psb_halo(x,desc_a,info) if(info /= psb_success_) then @@ -182,6 +177,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' end if + call psb_erractionrestore(err_act) return @@ -250,7 +246,7 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) else do i=1, n dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info) + call x(i)%asb(ncol,info,scratch=scratch) if (info /= 0) exit ! ..update halo elements.. call psb_halo(x(i),desc_a,info) diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index 009699aa..daac9767 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -57,7 +57,7 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_ipk_) :: i, loc_rows, loc_cols integer(psb_lpk_) :: mglob integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt @@ -198,7 +198,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act integer(psb_lpk_) :: mglob type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index d2a8e779..a9cbbe4b 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -138,11 +138,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (desc_a%is_bld()) then - if (.not.a%is_bld()) then - info = psb_err_invalid_a_and_cd_state_ - call psb_errpush(info,name) - goto 9999 - end if + if (local_) then info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index 21d4d8a5..d708e324 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -109,12 +109,10 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode) else bldmode_ = psb_matbld_noremote_ end if + call x%set_bld() if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - call x%set_dupl(dupl_) + call x%set_dupl(dupl) + end if call x%set_remote_build(bldmode_) call x%set_nrmv(izero) if (x%is_remote_build()) then diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index f5e5669f..ec8536b9 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -51,7 +51,7 @@ ! scratch - logical, optional If true, allocate without checking/zeroing contents. ! default: .false. ! -subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) +subroutine psb_iasb_vect(x, desc_a, info, mold, scratch, dupl) use psb_base_mod, psb_protect_name => psb_iasb_vect implicit none @@ -60,6 +60,7 @@ subroutine psb_iasb_vect(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 @@ -80,10 +81,9 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. + scratch_ = .false. if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) - dupl_ = x%get_dupl() ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -100,39 +100,83 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - if (scratch_) then - call x%free(info) - call x%bld(ncol,mold=mold) + dupl_ = x%get_dupl() + if (try_newins) then + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold,scratch=scratch_) + else + if (x%is_bld().and.present(dupl)) then + call x%set_dupl(dupl) + dupl_ = dupl + end if + + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + integer(psb_ipk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' else - if (x%is_remote_build()) then - block - integer(psb_lpk_), allocatable :: lvx(:) - integer(psb_ipk_), allocatable :: vx(:) - integer(psb_ipk_), allocatable :: ivx(:) - integer(psb_ipk_) :: nrmv, nx, i - - nrmv = x%get_nrmv() - call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) - nx = size(vx) - call psb_realloc(nx,ivx,info) - call desc_a%g2l(lvx,ivx,info,owned=.true.) - call x%ins(nx,ivx,vx,info) - end block - end if - - call x%asb(ncol,info) - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold) + else + if (x%is_bld().and.present(dupl)) then + dupl_ = dupl + end if + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + integer(psb_ipk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) end if - call x%cnv(mold) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' call psb_erractionrestore(err_act) return @@ -202,7 +246,7 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) else do i=1, n dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info) + call x(i)%asb(ncol,info,scratch=scratch) if (info /= 0) exit ! ..update halo elements.. call psb_halo(x(i),desc_a,info) diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index 4fa53429..598af33f 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -57,7 +57,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_ipk_) :: i, loc_rows, loc_cols integer(psb_lpk_) :: mglob integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt @@ -127,7 +127,7 @@ subroutine psb_iins_vect(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 @@ -198,7 +198,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act integer(psb_lpk_) :: mglob type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me @@ -261,7 +261,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,lval,info) + call x%ins(m,irl,lval,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -368,7 +368,7 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, local) do i=1,n if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ - if (info == 0) call x(i)%ins(m,irl,val(:,i),info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info) if (info /= 0) exit end do if (info /= 0) then diff --git a/base/tools/psb_lallc.f90 b/base/tools/psb_lallc.f90 index a781e55a..e89b4b15 100644 --- a/base/tools/psb_lallc.f90 +++ b/base/tools/psb_lallc.f90 @@ -109,12 +109,10 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode) else bldmode_ = psb_matbld_noremote_ end if + call x%set_bld() if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - call x%set_dupl(dupl_) + call x%set_dupl(dupl) + end if call x%set_remote_build(bldmode_) call x%set_nrmv(izero) if (x%is_remote_build()) then diff --git a/base/tools/psb_lasb.f90 b/base/tools/psb_lasb.f90 index baf55320..61e3de94 100644 --- a/base/tools/psb_lasb.f90 +++ b/base/tools/psb_lasb.f90 @@ -51,7 +51,7 @@ ! scratch - logical, optional If true, allocate without checking/zeroing contents. ! default: .false. ! -subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) +subroutine psb_lasb_vect(x, desc_a, info, mold, scratch, dupl) use psb_base_mod, psb_protect_name => psb_lasb_vect implicit none @@ -60,6 +60,7 @@ subroutine psb_lasb_vect(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 @@ -80,10 +81,9 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. + scratch_ = .false. if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) - dupl_ = x%get_dupl() ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -100,39 +100,83 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - if (scratch_) then - call x%free(info) - call x%bld(ncol,mold=mold) + dupl_ = x%get_dupl() + if (try_newins) then + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold,scratch=scratch_) + else + if (x%is_bld().and.present(dupl)) then + call x%set_dupl(dupl) + dupl_ = dupl + end if + + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + integer(psb_lpk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' else - if (x%is_remote_build()) then - block - integer(psb_lpk_), allocatable :: lvx(:) - integer(psb_lpk_), allocatable :: vx(:) - integer(psb_ipk_), allocatable :: ivx(:) - integer(psb_ipk_) :: nrmv, nx, i - - nrmv = x%get_nrmv() - call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) - nx = size(vx) - call psb_realloc(nx,ivx,info) - call desc_a%g2l(lvx,ivx,info,owned=.true.) - call x%ins(nx,ivx,vx,info) - end block - end if - - call x%asb(ncol,info) - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold) + else + if (x%is_bld().and.present(dupl)) then + dupl_ = dupl + end if + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + integer(psb_lpk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) end if - call x%cnv(mold) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' call psb_erractionrestore(err_act) return @@ -202,7 +246,7 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) else do i=1, n dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info) + call x(i)%asb(ncol,info,scratch=scratch) if (info /= 0) exit ! ..update halo elements.. call psb_halo(x(i),desc_a,info) diff --git a/base/tools/psb_lins.f90 b/base/tools/psb_lins.f90 index 90da8111..dc41d022 100644 --- a/base/tools/psb_lins.f90 +++ b/base/tools/psb_lins.f90 @@ -57,7 +57,7 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_ipk_) :: i, loc_rows, loc_cols integer(psb_lpk_) :: mglob integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt @@ -127,7 +127,7 @@ subroutine psb_lins_vect(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 @@ -198,7 +198,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act integer(psb_lpk_) :: mglob type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me @@ -261,7 +261,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,lval,info) + call x%ins(m,irl,lval,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -368,7 +368,7 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, local) do i=1,n if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ - if (info == 0) call x(i)%ins(m,irl,val(:,i),info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info) if (info /= 0) exit end do if (info /= 0) then diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index d318e45f..143e032b 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -109,12 +109,10 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode) else bldmode_ = psb_matbld_noremote_ end if + call x%set_bld() if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - call x%set_dupl(dupl_) + call x%set_dupl(dupl) + end if call x%set_remote_build(bldmode_) call x%set_nrmv(izero) if (x%is_remote_build()) then diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index 315e24ff..0fe6f545 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -51,7 +51,7 @@ ! scratch - logical, optional If true, allocate without checking/zeroing contents. ! default: .false. ! -subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) +subroutine psb_sasb_vect(x, desc_a, info, mold, scratch, dupl) use psb_base_mod, psb_protect_name => psb_sasb_vect implicit none @@ -60,6 +60,7 @@ subroutine psb_sasb_vect(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 @@ -80,10 +81,9 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. + scratch_ = .false. if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) - dupl_ = x%get_dupl() ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -100,39 +100,83 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - if (scratch_) then - call x%free(info) - call x%bld(ncol,mold=mold) + dupl_ = x%get_dupl() + if (try_newins) then + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold,scratch=scratch_) + else + if (x%is_bld().and.present(dupl)) then + call x%set_dupl(dupl) + dupl_ = dupl + end if + + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + real(psb_spk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' else - if (x%is_remote_build()) then - block - integer(psb_lpk_), allocatable :: lvx(:) - real(psb_spk_), allocatable :: vx(:) - integer(psb_ipk_), allocatable :: ivx(:) - integer(psb_ipk_) :: nrmv, nx, i - - nrmv = x%get_nrmv() - call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) - nx = size(vx) - call psb_realloc(nx,ivx,info) - call desc_a%g2l(lvx,ivx,info,owned=.true.) - call x%ins(nx,ivx,vx,info) - end block - end if - - call x%asb(ncol,info) - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold) + else + if (x%is_bld().and.present(dupl)) then + dupl_ = dupl + end if + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + real(psb_spk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) end if - call x%cnv(mold) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' call psb_erractionrestore(err_act) return @@ -202,7 +246,7 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) else do i=1, n dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info) + call x(i)%asb(ncol,info,scratch=scratch) if (info /= 0) exit ! ..update halo elements.. call psb_halo(x(i),desc_a,info) diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index ddead81f..25c7248a 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -57,7 +57,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_ipk_) :: i, loc_rows, loc_cols integer(psb_lpk_) :: mglob integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt @@ -127,7 +127,7 @@ subroutine psb_sins_vect(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 @@ -198,7 +198,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act integer(psb_lpk_) :: mglob type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me @@ -261,7 +261,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,lval,info) + call x%ins(m,irl,lval,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -368,7 +368,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, local) do i=1,n if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ - if (info == 0) call x(i)%ins(m,irl,val(:,i),info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info) if (info /= 0) exit end do if (info /= 0) then diff --git a/base/tools/psb_sspasb.f90 b/base/tools/psb_sspasb.f90 index 110097c5..60d1c25f 100644 --- a/base/tools/psb_sspasb.f90 +++ b/base/tools/psb_sspasb.f90 @@ -44,7 +44,7 @@ ! psb_upd_perm_ Permutation(more memory) ! ! -subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and) +subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) use psb_base_mod, psb_protect_name => psb_sspasb use psb_sort_mod use psi_mod @@ -59,6 +59,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and) character(len=*), optional, intent(in) :: afmt class(psb_s_base_sparse_mat), intent(in), optional :: mold logical, intent(in), optional :: bld_and + integer(psb_ipk_), optional, intent(in) :: dupl !....Locals.... type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, err_act @@ -103,7 +104,12 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and) !check on errors encountered in psdspins if (a%is_bld()) then - dupl_ = a%get_dupl() + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = a%get_dupl() + end if + ! ! First case: we come from a fresh build. ! @@ -180,7 +186,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and) if (bld_and_) then !!$ allocate(a%ad,mold=a%a) !!$ allocate(a%and,mold=a%a)o - call a%split_nd(n_row,n_col,info) +!!$ call a%split_nd(n_row,n_col,info) !!$ block !!$ character(len=1024) :: fname !!$ type(psb_s_coo_sparse_mat) :: acoo diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index b43e57ca..fa7518fa 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -109,12 +109,10 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode) else bldmode_ = psb_matbld_noremote_ end if + call x%set_bld() if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_def_ - end if - call x%set_dupl(dupl_) + call x%set_dupl(dupl) + end if call x%set_remote_build(bldmode_) call x%set_nrmv(izero) if (x%is_remote_build()) then diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index decbfdec..e21eaf7f 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -51,7 +51,7 @@ ! scratch - logical, optional If true, allocate without checking/zeroing contents. ! default: .false. ! -subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) +subroutine psb_zasb_vect(x, desc_a, info, mold, scratch, dupl) use psb_base_mod, psb_protect_name => psb_zasb_vect implicit none @@ -60,6 +60,7 @@ subroutine psb_zasb_vect(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 @@ -80,10 +81,9 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - scratch_ = .false. + scratch_ = .false. if (present(scratch)) scratch_ = scratch call psb_info(ctxt, me, np) - dupl_ = x%get_dupl() ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -100,39 +100,83 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - if (scratch_) then - call x%free(info) - call x%bld(ncol,mold=mold) + dupl_ = x%get_dupl() + if (try_newins) then + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold,scratch=scratch_) + else + if (x%is_bld().and.present(dupl)) then + call x%set_dupl(dupl) + dupl_ = dupl + end if + + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + complex(psb_dpk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' else - if (x%is_remote_build()) then - block - integer(psb_lpk_), allocatable :: lvx(:) - complex(psb_dpk_), allocatable :: vx(:) - integer(psb_ipk_), allocatable :: ivx(:) - integer(psb_ipk_) :: nrmv, nx, i - - nrmv = x%get_nrmv() - call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) - nx = size(vx) - call psb_realloc(nx,ivx,info) - call desc_a%g2l(lvx,ivx,info,owned=.true.) - call x%ins(nx,ivx,vx,info) - end block - end if - - call x%asb(ncol,info) - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_halo') - goto 9999 + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold) + else + if (x%is_bld().and.present(dupl)) then + dupl_ = dupl + end if + if (x%is_remote_build()) then + block + integer(psb_lpk_), allocatable :: lvx(:) + complex(psb_dpk_), allocatable :: vx(:) + integer(psb_ipk_), allocatable :: ivx(:) + integer(psb_ipk_) :: nrmv, nx, i + + nrmv = x%get_nrmv() + call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) + nx = size(vx) + call psb_realloc(nx,ivx,info) + call desc_a%g2l(lvx,ivx,info,owned=.true.) + call x%ins(nx,ivx,vx,nrow,info) + end block + end if + + call x%asb(ncol,info,scratch=scratch) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) end if - call x%cnv(mold) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' call psb_erractionrestore(err_act) return @@ -202,7 +246,7 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) else do i=1, n dupl_ = x(i)%get_dupl() - call x(i)%asb(ncol,info) + call x(i)%asb(ncol,info,scratch=scratch) if (info /= 0) exit ! ..update halo elements.. call psb_halo(x(i),desc_a,info) diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index 43e5d5cd..1c16eb96 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -57,7 +57,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_ipk_) :: i, loc_rows, loc_cols integer(psb_lpk_) :: mglob integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt @@ -127,7 +127,7 @@ subroutine psb_zins_vect(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 @@ -198,7 +198,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act integer(psb_lpk_) :: mglob type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me @@ -261,7 +261,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,lval,info) + call x%ins(m,irl,lval,loc_rows,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -368,7 +368,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, local) do i=1,n if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ - if (info == 0) call x(i)%ins(m,irl,val(:,i),info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info) if (info /= 0) exit end do if (info /= 0) then diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index 2cb53368..deba9edc 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -44,7 +44,7 @@ ! psb_upd_perm_ Permutation(more memory) ! ! -subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and) +subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) use psb_base_mod, psb_protect_name => psb_zspasb use psb_sort_mod use psi_mod @@ -59,6 +59,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and) character(len=*), optional, intent(in) :: afmt class(psb_z_base_sparse_mat), intent(in), optional :: mold logical, intent(in), optional :: bld_and + integer(psb_ipk_), optional, intent(in) :: dupl !....Locals.... type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, err_act @@ -103,7 +104,12 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and) !check on errors encountered in psdspins if (a%is_bld()) then - dupl_ = a%get_dupl() + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = a%get_dupl() + end if + ! ! First case: we come from a fresh build. ! @@ -180,7 +186,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and) if (bld_and_) then !!$ allocate(a%ad,mold=a%a) !!$ allocate(a%and,mold=a%a)o - call a%split_nd(n_row,n_col,info) +!!$ call a%split_nd(n_row,n_col,info) !!$ block !!$ character(len=1024) :: fname !!$ type(psb_z_coo_sparse_mat) :: acoo diff --git a/cuda/psb_c_cuda_vect_mod.F90 b/cuda/psb_c_cuda_vect_mod.F90 index 95f6d602..96c8ec1f 100644 --- a/cuda/psb_c_cuda_vect_mod.F90 +++ b/cuda/psb_c_cuda_vect_mod.F90 @@ -560,12 +560,20 @@ contains end subroutine c_cuda_sctb_buf - subroutine c_cuda_bld_x(x,this) + subroutine c_cuda_bld_x(x,this,scratch) use psb_base_mod complex(psb_spk_), intent(in) :: this(:) class(psb_c_vect_cuda), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call psb_realloc(size(this),x%v,info) if (info /= 0) then info=psb_err_alloc_request_ @@ -578,11 +586,19 @@ contains end subroutine c_cuda_bld_x - subroutine c_cuda_bld_mn(x,n) + subroutine c_cuda_bld_mn(x,n,scratch) integer(psb_mpk_), intent(in) :: n class(psb_c_vect_cuda), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_ipk_) :: info + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if call x%all(n,info) if (info /= 0) then call psb_errpush(info,'c_cuda_bld_n',i_err=(/n,n,n,n,n/)) @@ -679,26 +695,34 @@ contains call x%set_scal(czero) end subroutine c_cuda_zero - subroutine c_cuda_asb_m(n, x, info) + subroutine c_cuda_asb_m(n, x, info, scratch) use psi_serial_mod use psb_realloc_mod implicit none integer(psb_mpk_), intent(in) :: n class(psb_c_vect_cuda), intent(inout) :: x integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ integer(psb_mpk_) :: nd - + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if if (x%is_dev()) then nd = getMultiVecDeviceSize(x%deviceVect) if (nd < n) then call x%sync() - call x%psb_c_base_vect_type%asb(n,info) + call x%psb_c_base_vect_type%asb(n,info,scratch=scratch_) if (info == psb_success_) call x%sync_space(info) call x%set_host() end if else ! if (x%get_nrows()