diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 395f45741..f1e8949bb 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -203,14 +203,16 @@ module psb_const_mod ! ! - ! State of matrices. + ! State of matrices/vectors. ! integer(psb_ipk_), parameter :: psb_invalid_ = -1 integer(psb_ipk_), parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 integer(psb_ipk_), parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 - integer(psb_ipk_), parameter :: psb_matbld_noremote_=0, psb_matbld_remote_=1 + integer(psb_ipk_), parameter :: psb_vect_null_=0, psb_vect_bld_=1 + integer(psb_ipk_), parameter :: psb_vect_asb_=2, psb_vect_upd_=4 + integer(psb_ipk_), parameter :: psb_ireg_flgs_=10, psb_ip2_=0 integer(psb_ipk_), parameter :: psb_iflag_=2, psb_ichk_=3 @@ -223,9 +225,10 @@ module psb_const_mod ! Duplicate coefficients handling ! These are usually set while calling spcnv as one of its ! optional arugments. - integer(psb_ipk_), parameter :: psb_dupl_add_ = 0 - integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 1 - integer(psb_ipk_), parameter :: psb_dupl_err_ = 2 + integer(psb_ipk_), parameter :: psb_dupl_null_ = 0 + integer(psb_ipk_), parameter :: psb_dupl_add_ = 1 + integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 2 + integer(psb_ipk_), parameter :: psb_dupl_err_ = 3 integer(psb_ipk_), parameter :: psb_dupl_def_ = psb_dupl_add_ ! Matrix update mode integer(psb_ipk_), parameter :: psb_upd_srch_ = 98764 diff --git a/base/modules/serial/psb_base_mat_mod.F90 b/base/modules/serial/psb_base_mat_mod.F90 index 42d480d87..716d78d33 100644 --- a/base/modules/serial/psb_base_mat_mod.F90 +++ b/base/modules/serial/psb_base_mat_mod.F90 @@ -128,7 +128,7 @@ module psb_base_mat_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_mat_mod. - integer(psb_ipk_), private :: state + integer(psb_ipk_), private :: bldstate !> How to treat duplicate elements when !! transitioning from the BUILD to the ASSEMBLED state. !! While many formats would allow for duplicate @@ -137,7 +137,7 @@ module psb_base_mat_mod !! BUILD state; in our overall design, only COO matrices !! can ever be in the BUILD state, hence all other formats !! cannot have duplicate entries. - integer(psb_ipk_), private :: duplicate + integer(psb_ipk_), private :: duplicate = psb_dupl_null_ !> Is the matrix symmetric? (must also be square) logical, private :: symmetric !> Is the matrix triangular? (must also be square) @@ -503,7 +503,7 @@ module psb_base_mat_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_mat_mod. - integer(psb_ipk_), private :: state + integer(psb_ipk_), private :: bldstate !> How to treat duplicate elements when !! transitioning from the BUILD to the ASSEMBLED state. !! While many formats would allow for duplicate @@ -909,7 +909,7 @@ contains implicit none class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res - res = a%state + res = a%bldstate end function psb_base_get_state function psb_base_get_nrows(a) result(res) @@ -945,7 +945,7 @@ contains implicit none class(psb_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: n - a%state = n + a%bldstate = n end subroutine psb_base_set_state @@ -960,28 +960,28 @@ contains implicit none class(psb_base_sparse_mat), intent(inout) :: a - a%state = psb_spmat_null_ + a%bldstate = psb_spmat_null_ end subroutine psb_base_set_null subroutine psb_base_set_bld(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a - a%state = psb_spmat_bld_ + a%bldstate = psb_spmat_bld_ end subroutine psb_base_set_bld subroutine psb_base_set_upd(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a - a%state = psb_spmat_upd_ + a%bldstate = psb_spmat_upd_ end subroutine psb_base_set_upd subroutine psb_base_set_asb(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a - a%state = psb_spmat_asb_ + a%bldstate = psb_spmat_asb_ end subroutine psb_base_set_asb subroutine psb_base_set_sorted(a,val) @@ -1107,28 +1107,28 @@ contains implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res - res = (a%state == psb_spmat_null_) + res = (a%bldstate == psb_spmat_null_) end function psb_base_is_null function psb_base_is_bld(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res - res = (a%state == psb_spmat_bld_) + res = (a%bldstate == psb_spmat_bld_) end function psb_base_is_bld function psb_base_is_upd(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res - res = (a%state == psb_spmat_upd_) + res = (a%bldstate == psb_spmat_upd_) end function psb_base_is_upd function psb_base_is_asb(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res - res = (a%state == psb_spmat_asb_) + res = (a%bldstate == psb_spmat_asb_) end function psb_base_is_asb function psb_base_is_sorted(a) result(res) @@ -1185,7 +1185,7 @@ contains b%m = a%n b%n = a%m - b%state = a%state + b%bldstate = a%bldstate b%duplicate = a%duplicate b%triangle = a%triangle b%symmetric = a%symmetric @@ -1205,7 +1205,7 @@ contains b%m = a%n b%n = a%m - b%state = a%state + b%bldstate = a%bldstate b%duplicate = a%duplicate b%triangle = a%triangle b%symmetric = a%symmetric @@ -1225,7 +1225,7 @@ contains itmp = a%m a%m = a%n a%n = itmp - a%state = a%state + a%bldstate = a%bldstate a%duplicate = a%duplicate a%triangle = a%triangle a%unitd = a%unitd @@ -1402,7 +1402,7 @@ contains implicit none class(psb_lbase_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res - res = a%state + res = a%bldstate end function psb_lbase_get_state function psb_lbase_get_nrows(a) result(res) @@ -1479,7 +1479,7 @@ contains implicit none class(psb_lbase_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: n - a%state = n + a%bldstate = n end subroutine psb_lbase_set_state @@ -1494,28 +1494,28 @@ contains implicit none class(psb_lbase_sparse_mat), intent(inout) :: a - a%state = psb_spmat_null_ + a%bldstate = psb_spmat_null_ end subroutine psb_lbase_set_null subroutine psb_lbase_set_bld(a) implicit none class(psb_lbase_sparse_mat), intent(inout) :: a - a%state = psb_spmat_bld_ + a%bldstate = psb_spmat_bld_ end subroutine psb_lbase_set_bld subroutine psb_lbase_set_upd(a) implicit none class(psb_lbase_sparse_mat), intent(inout) :: a - a%state = psb_spmat_upd_ + a%bldstate = psb_spmat_upd_ end subroutine psb_lbase_set_upd subroutine psb_lbase_set_asb(a) implicit none class(psb_lbase_sparse_mat), intent(inout) :: a - a%state = psb_spmat_asb_ + a%bldstate = psb_spmat_asb_ end subroutine psb_lbase_set_asb subroutine psb_lbase_set_sorted(a,val) @@ -1652,28 +1652,28 @@ contains implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res - res = (a%state == psb_spmat_null_) + res = (a%bldstate == psb_spmat_null_) end function psb_lbase_is_null function psb_lbase_is_bld(a) result(res) implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res - res = (a%state == psb_spmat_bld_) + res = (a%bldstate == psb_spmat_bld_) end function psb_lbase_is_bld function psb_lbase_is_upd(a) result(res) implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res - res = (a%state == psb_spmat_upd_) + res = (a%bldstate == psb_spmat_upd_) end function psb_lbase_is_upd function psb_lbase_is_asb(a) result(res) implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res - res = (a%state == psb_spmat_asb_) + res = (a%bldstate == psb_spmat_asb_) end function psb_lbase_is_asb function psb_lbase_is_sorted(a) result(res) @@ -1719,7 +1719,7 @@ contains b%m = a%n b%n = a%m - b%state = a%state + b%bldstate = a%bldstate b%duplicate = a%duplicate b%triangle = a%triangle b%unitd = a%unitd @@ -1738,7 +1738,7 @@ contains b%m = a%n b%n = a%m - b%state = a%state + b%bldstate = a%bldstate b%duplicate = a%duplicate b%triangle = a%triangle b%unitd = a%unitd @@ -1757,7 +1757,7 @@ contains itmp = a%m a%m = a%n a%n = itmp - a%state = a%state + a%bldstate = a%bldstate a%duplicate = a%duplicate a%triangle = a%triangle a%unitd = a%unitd @@ -1891,7 +1891,7 @@ contains lb%m = ib%m lb%n = ib%n - lb%state = ib%state + lb%bldstate = ib%bldstate lb%duplicate = ib%duplicate lb%triangle = ib%triangle lb%unitd = ib%unitd @@ -1907,7 +1907,7 @@ contains ib%m = lb%m ib%n = lb%n - ib%state = lb%state + ib%bldstate = lb%bldstate ib%duplicate = lb%duplicate ib%triangle = lb%triangle ib%unitd = lb%unitd diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index 8bc8a171b..3860d6553 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -65,6 +65,18 @@ module psb_d_base_vect_mod real(psb_dpk_), allocatable :: v(:) real(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -77,17 +89,30 @@ 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 + procedure, pass(x) :: set_dupl => d_base_set_dupl + procedure, pass(x) :: get_dupl => d_base_get_dupl + procedure, pass(x) :: set_state => d_base_set_state + procedure, pass(x) :: set_null => d_base_set_null + procedure, pass(x) :: set_bld => d_base_set_bld + procedure, pass(x) :: set_upd => d_base_set_upd + procedure, pass(x) :: set_asb => d_base_set_asb + procedure, pass(x) :: get_state => d_base_get_state + procedure, pass(x) :: is_null => d_base_is_null + procedure, pass(x) :: is_bld => d_base_is_bld + procedure, pass(x) :: is_upd => d_base_is_upd + procedure, pass(x) :: is_asb => d_base_is_asb ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -228,6 +253,7 @@ module psb_d_base_vect_mod module procedure constructor, size_const end interface psb_d_base_vect + logical, parameter :: try_newins=.true. contains ! @@ -347,9 +373,28 @@ 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 end subroutine d_base_all + subroutine d_base_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_d_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) then + call x%sync() + x%v(:) = dzero + call x%set_host() + end if + + end subroutine d_base_reinit + !> Function base_mold: !! \memberof psb_d_base_vect_type !! \brief Mold method: return a variable with the same dynamic type @@ -395,20 +440,77 @@ contains !! \param info return code !! ! - subroutine d_base_ins_a(n,irl,val,dupl,x,info) + subroutine d_base_ins_a(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_d_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_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 - +#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) + end if + enddo + call x%set_ncfs(k) + 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_) + 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 + end if +#else if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ else if (n > min(size(irl),size(val))) then @@ -445,6 +547,7 @@ contains ! !$ goto 9999 end select end if +#endif call x%set_host() if (info /= 0) then call psb_errpush(info,'base_vect_ins') @@ -453,11 +556,11 @@ contains end subroutine d_base_ins_a - subroutine d_base_ins_v(n,irl,val,dupl,x,info) + subroutine d_base_ins_v(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_d_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_d_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -470,7 +573,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') @@ -521,12 +624,52 @@ contains 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 + real(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 (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%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'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 d_base_asb_m @@ -551,13 +694,54 @@ contains 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 + real(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 (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%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'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 d_base_asb_e ! @@ -645,7 +829,104 @@ contains & 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 + integer(psb_ipk_) :: res + res = x%ncfs + end function d_base_get_ncfs + function d_base_get_dupl(x) result(res) + implicit none + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function d_base_get_dupl + + function d_base_get_state(x) result(res) + implicit none + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function d_base_get_state + + function d_base_is_null(x) result(res) + implicit none + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function d_base_is_null + + function d_base_is_bld(x) result(res) + implicit none + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function d_base_is_bld + + function d_base_is_upd(x) result(res) + implicit none + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function d_base_is_upd + + function d_base_is_asb(x) result(res) + implicit none + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function d_base_is_asb + + subroutine d_base_set_ncfs(n,x) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine d_base_set_ncfs + + subroutine d_base_set_dupl(n,x) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine d_base_set_dupl + + subroutine d_base_set_state(n,x) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine d_base_set_state + + subroutine d_base_set_null(x) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine d_base_set_null + + subroutine d_base_set_bld(x) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine d_base_set_bld + + subroutine d_base_set_upd(x) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine d_base_set_upd + + subroutine d_base_set_asb(x) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + + 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 302e6fc1c..c52946cfb 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -45,9 +45,8 @@ 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_) :: dupl = psb_dupl_add_ + integer(psb_ipk_) :: nrmv = 0 + integer(psb_ipk_) :: remote_build = psb_matbld_noremote_ real(psb_dpk_), allocatable :: rmtv(:) integer(psb_lpk_), allocatable :: rmidx(:) contains @@ -56,14 +55,26 @@ module psb_d_vect_mod procedure, pass(x) :: get_fmt => d_vect_get_fmt procedure, pass(x) :: is_remote_build => d_vect_is_remote_build procedure, pass(x) :: set_remote_build => d_vect_set_remote_build - procedure, pass(x) :: get_dupl => d_vect_get_dupl - procedure, pass(x) :: set_dupl => d_vect_set_dupl procedure, pass(x) :: get_nrmv => d_vect_get_nrmv procedure, pass(x) :: set_nrmv => d_vect_set_nrmv procedure, pass(x) :: all => d_vect_all procedure, pass(x) :: reall => d_vect_reall procedure, pass(x) :: zero => d_vect_zero procedure, pass(x) :: asb => d_vect_asb + procedure, pass(x) :: set_dupl => d_vect_set_dupl + procedure, pass(x) :: get_dupl => d_vect_get_dupl + procedure, pass(x) :: set_state => d_vect_set_state + procedure, pass(x) :: set_null => d_vect_set_null + procedure, pass(x) :: set_bld => d_vect_set_bld + procedure, pass(x) :: set_upd => d_vect_set_upd + procedure, pass(x) :: set_asb => d_vect_set_asb + procedure, pass(x) :: get_state => d_vect_get_state + procedure, pass(x) :: is_null => d_vect_is_null + procedure, pass(x) :: is_bld => d_vect_is_bld + 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 @@ -194,7 +205,11 @@ contains implicit none class(psb_d_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 d_vect_get_dupl subroutine d_vect_set_dupl(x,val) @@ -202,13 +217,93 @@ contains class(psb_d_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 d_vect_set_dupl + function d_vect_get_state(x) result(res) + implicit none + class(psb_d_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 d_vect_get_state + + function d_vect_is_null(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function d_vect_is_null + + function d_vect_is_bld(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function d_vect_is_bld + + function d_vect_is_upd(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function d_vect_is_upd + + function d_vect_is_asb(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function d_vect_is_asb + + subroutine d_vect_set_state(n,x) + implicit none + class(psb_d_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 d_vect_set_state + + + subroutine d_vect_set_null(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine d_vect_set_null + + subroutine d_vect_set_bld(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine d_vect_set_bld + + subroutine d_vect_set_upd(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine d_vect_set_upd + + subroutine d_vect_set_asb(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + 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 @@ -457,8 +552,20 @@ contains else info = psb_err_alloc_dealloc_ end if + call x%set_bld() 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 + + if (allocated(x%v)) call x%v%reinit(info) + call x%set_upd() + + end subroutine d_vect_reinit + subroutine d_vect_reall(n, x, info) implicit none @@ -547,11 +654,11 @@ contains end subroutine d_vect_free - subroutine d_vect_ins_a(n,irl,val,x,info) + subroutine d_vect_ins_a(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_d_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_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info @@ -564,15 +671,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 d_vect_ins_a - subroutine d_vect_ins_v(n,irl,val,x,info) + subroutine d_vect_ins_v(n,irl,val,x,maxr,info) use psi_serial_mod implicit none class(psb_d_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_d_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -585,7 +692,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 d_vect_ins_v diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index b2ac3a66e..2d583317d 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -70,7 +70,7 @@ Module psb_d_tools_mod interface psb_geasb - subroutine psb_dasb_vect(x, desc_a, info,mold, scratch) + subroutine psb_dasb_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_d_tools_mod integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl end subroutine psb_dasb_vect subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch) import @@ -250,16 +251,17 @@ Module psb_d_tools_mod end interface interface psb_spasb - subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and) + subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) import implicit none 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 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/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 7b7b21f72..45116e074 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -111,10 +111,11 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode) end if if (present(dupl)) then dupl_ = dupl - else - dupl_ = psb_dupl_def_ +!!$ else +!!$ dupl_ = psb_dupl_def_ end if - call x%set_dupl(dupl_) +!!$ call x%set_dupl(dupl_) + call x%set_bld() 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 19a19ff14..ead3d1d02 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) +subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl) use psb_base_mod, psb_protect_name => psb_dasb_vect implicit none @@ -60,6 +60,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: dupl ! local variables type(psb_ctxt_type) :: ctxt @@ -68,6 +69,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) 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' @@ -83,7 +85,6 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) 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_ @@ -94,46 +95,93 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) call psb_errpush(info,name) goto 9999 end if - + nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() 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) - else - - 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) - call psb_realloc(nx,ivx,info) - call desc_a%g2l(lvx,ivx,info,owned=.true.) - call x%ins(nx,ivx,vx,info) - end block + if (try_newins) then +!!$ if (present(dupl)) then +!!$ call x%set_dupl(dupl) +!!$ end if + 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 + 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) + 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) + ! ..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 + dupl_ = x%get_dupl() - 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 +!!$ 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) + 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) + ! ..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 diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index d35292298..009699aab 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -127,7 +127,7 @@ subroutine psb_dins_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 @@ -261,7 +261,7 @@ subroutine psb_dins_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_dins_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_dspasb.f90 b/base/tools/psb_dspasb.f90 index 236568a18..61f20a399 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -44,7 +44,7 @@ ! psb_upd_perm_ Permutation(more memory) ! ! -subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and) +subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) use psb_base_mod, psb_protect_name => psb_dspasb use psb_sort_mod use psi_mod @@ -59,6 +59,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and) 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 !....Locals.... type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me, err_act @@ -103,7 +104,12 @@ subroutine psb_dspasb(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_dspasb(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_d_coo_sparse_mat) :: acoo diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index a9cbbe4b6..d2a8e7793 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -138,7 +138,11 @@ 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/cuda/psb_d_cuda_vect_mod.F90 b/cuda/psb_d_cuda_vect_mod.F90 index 080c86862..f15e4bf08 100644 --- a/cuda/psb_d_cuda_vect_mod.F90 +++ b/cuda/psb_d_cuda_vect_mod.F90 @@ -1252,11 +1252,11 @@ contains call x%free(info) end subroutine d_cuda_vect_finalize - subroutine d_cuda_ins_v(n,irl,val,dupl,x,info) + subroutine d_cuda_ins_v(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_d_vect_cuda), 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_d_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -1285,7 +1285,7 @@ contains if (.not.done_cuda) then if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() - call x%ins(n,irl%v,val%v,dupl,info) + call x%ins(n,irl%v,val%v,dupl,maxr,info) end if if (info /= 0) then @@ -1295,11 +1295,11 @@ contains end subroutine d_cuda_ins_v - subroutine d_cuda_ins_a(n,irl,val,dupl,x,info) + subroutine d_cuda_ins_a(n,irl,val,dupl,x,maxr,info) use psi_serial_mod implicit none class(psb_d_vect_cuda), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: irl(:) real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info @@ -1308,7 +1308,7 @@ contains info = 0 if (x%is_dev()) call x%sync() - call x%psb_d_base_vect_type%ins(n,irl,val,dupl,info) + call x%psb_d_base_vect_type%ins(n,irl,val,dupl,maxr,info) call x%set_host() end subroutine d_cuda_ins_a diff --git a/openacc/psb_d_oacc_vect_mod.F90 b/openacc/psb_d_oacc_vect_mod.F90 index 830b22161..d765b3ab9 100644 --- a/openacc/psb_d_oacc_vect_mod.F90 +++ b/openacc/psb_d_oacc_vect_mod.F90 @@ -620,11 +620,11 @@ contains end subroutine inner_gth end subroutine d_oacc_gthzv_x - subroutine d_oacc_ins_v(n, irl, val, dupl, x, info) + subroutine d_oacc_ins_v(n, irl, val, dupl, x,maxr, info) use psi_serial_mod implicit none class(psb_d_vect_oacc), 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_d_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info @@ -661,7 +661,7 @@ contains type is (psb_d_vect_oacc) if (vval%is_dev()) call vval%sync() end select - call x%ins(n, irl%v, val%v, dupl, info) + call x%ins(n, irl%v, val%v, dupl,maxr, info) end if if (info /= 0) then @@ -671,11 +671,11 @@ contains end subroutine d_oacc_ins_v - subroutine d_oacc_ins_a(n, irl, val, dupl, x, info) + subroutine d_oacc_ins_a(n, irl, val, dupl, x,maxr, info) use psi_serial_mod implicit none class(psb_d_vect_oacc), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: irl(:) real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info @@ -684,7 +684,7 @@ contains info = 0 if (x%is_dev()) call x%sync() - call x%psb_d_base_vect_type%ins(n, irl, val, dupl, info) + call x%psb_d_base_vect_type%ins(n, irl, val, dupl,maxr, info) call x%set_host() diff --git a/test/pdegen/psb_d_pde3d.F90 b/test/pdegen/psb_d_pde3d.F90 index cac1c413b..5ff37a14e 100644 --- a/test/pdegen/psb_d_pde3d.F90 +++ b/test/pdegen/psb_d_pde3d.F90 @@ -606,9 +606,9 @@ contains t1 = psb_wtime() if (info == psb_success_) then if (present(amold)) then - call psb_spasb(a,desc_a,info,mold=amold) + call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_) else - call psb_spasb(a,desc_a,info,afmt=afmt) + call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_) end if end if call psb_barrier(ctxt) @@ -618,8 +618,8 @@ contains call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold) - if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold) + if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_) + if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='asb rout.'