fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

First round of changes for vector builds

Browse Source
pull/31/head
sfilippone 8 months ago
parent 388b679d8a
commit 98a6eba948
13 changed files with 594 additions and 142 deletions
Show Stats Download Patch File Download Diff File

13
base/modules/psb_const_mod.F90
Unescape Escape View File

@ -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_invalid_ = -1
integer(psb_ipk_), parameter :: psb_spmat_null_=0, psb_spmat_bld_=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_spmat_asb_=2, psb_spmat_upd_=4
integer(psb_ipk_), parameter :: psb_matbld_noremote_=0, psb_matbld_remote_=1 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_ireg_flgs_=10, psb_ip2_=0
integer(psb_ipk_), parameter :: psb_iflag_=2, psb_ichk_=3 integer(psb_ipk_), parameter :: psb_iflag_=2, psb_ichk_=3
@ -223,9 +225,10 @@ module psb_const_mod
! Duplicate coefficients handling ! Duplicate coefficients handling
! These are usually set while calling spcnv as one of its ! These are usually set while calling spcnv as one of its
! optional arugments. ! optional arugments.
integer(psb_ipk_), parameter :: psb_dupl_add_ = 0 integer(psb_ipk_), parameter :: psb_dupl_null_ = 0
integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 1 integer(psb_ipk_), parameter :: psb_dupl_add_ = 1
integer(psb_ipk_), parameter :: psb_dupl_err_ = 2 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_ integer(psb_ipk_), parameter :: psb_dupl_def_ = psb_dupl_add_
! Matrix update mode ! Matrix update mode
integer(psb_ipk_), parameter :: psb_upd_srch_ = 98764 integer(psb_ipk_), parameter :: psb_upd_srch_ = 98764

62
base/modules/serial/psb_base_mat_mod.F90
Unescape Escape View File

@ -128,7 +128,7 @@ module psb_base_mat_mod
!! in already existing entries. !! in already existing entries.
!! The transitions among the states are detailed in !! The transitions among the states are detailed in
!! psb_T_mat_mod. !! psb_T_mat_mod.
integer(psb_ipk_), private :: state integer(psb_ipk_), private :: bldstate
!> How to treat duplicate elements when !> How to treat duplicate elements when
!! transitioning from the BUILD to the ASSEMBLED state. !! transitioning from the BUILD to the ASSEMBLED state.
!! While many formats would allow for duplicate !! 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 !! BUILD state; in our overall design, only COO matrices
!! can ever be in the BUILD state, hence all other formats !! can ever be in the BUILD state, hence all other formats
!! cannot have duplicate entries. !! 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) !> Is the matrix symmetric? (must also be square)
logical, private :: symmetric logical, private :: symmetric
!> Is the matrix triangular? (must also be square) !> Is the matrix triangular? (must also be square)
@ -503,7 +503,7 @@ module psb_base_mat_mod
!! in already existing entries. !! in already existing entries.
!! The transitions among the states are detailed in !! The transitions among the states are detailed in
!! psb_T_mat_mod. !! psb_T_mat_mod.
integer(psb_ipk_), private :: state integer(psb_ipk_), private :: bldstate
!> How to treat duplicate elements when !> How to treat duplicate elements when
!! transitioning from the BUILD to the ASSEMBLED state. !! transitioning from the BUILD to the ASSEMBLED state.
!! While many formats would allow for duplicate !! While many formats would allow for duplicate
@ -909,7 +909,7 @@ contains
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = a%state res = a%bldstate
end function psb_base_get_state end function psb_base_get_state
function psb_base_get_nrows(a) result(res) function psb_base_get_nrows(a) result(res)
@ -945,7 +945,7 @@ contains
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
a%state = n a%bldstate = n
end subroutine psb_base_set_state end subroutine psb_base_set_state
@ -960,28 +960,28 @@ contains
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_null_ a%bldstate = psb_spmat_null_
end subroutine psb_base_set_null end subroutine psb_base_set_null
subroutine psb_base_set_bld(a) subroutine psb_base_set_bld(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_bld_ a%bldstate = psb_spmat_bld_
end subroutine psb_base_set_bld end subroutine psb_base_set_bld
subroutine psb_base_set_upd(a) subroutine psb_base_set_upd(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_upd_ a%bldstate = psb_spmat_upd_
end subroutine psb_base_set_upd end subroutine psb_base_set_upd
subroutine psb_base_set_asb(a) subroutine psb_base_set_asb(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_asb_ a%bldstate = psb_spmat_asb_
end subroutine psb_base_set_asb end subroutine psb_base_set_asb
subroutine psb_base_set_sorted(a,val) subroutine psb_base_set_sorted(a,val)
@ -1107,28 +1107,28 @@ contains
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_null_) res = (a%bldstate == psb_spmat_null_)
end function psb_base_is_null end function psb_base_is_null
function psb_base_is_bld(a) result(res) function psb_base_is_bld(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_bld_) res = (a%bldstate == psb_spmat_bld_)
end function psb_base_is_bld end function psb_base_is_bld
function psb_base_is_upd(a) result(res) function psb_base_is_upd(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_upd_) res = (a%bldstate == psb_spmat_upd_)
end function psb_base_is_upd end function psb_base_is_upd
function psb_base_is_asb(a) result(res) function psb_base_is_asb(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_asb_) res = (a%bldstate == psb_spmat_asb_)
end function psb_base_is_asb end function psb_base_is_asb
function psb_base_is_sorted(a) result(res) function psb_base_is_sorted(a) result(res)
@ -1185,7 +1185,7 @@ contains
b%m = a%n b%m = a%n
b%n = a%m b%n = a%m
b%state = a%state b%bldstate = a%bldstate
b%duplicate = a%duplicate b%duplicate = a%duplicate
b%triangle = a%triangle b%triangle = a%triangle
b%symmetric = a%symmetric b%symmetric = a%symmetric
@ -1205,7 +1205,7 @@ contains
b%m = a%n b%m = a%n
b%n = a%m b%n = a%m
b%state = a%state b%bldstate = a%bldstate
b%duplicate = a%duplicate b%duplicate = a%duplicate
b%triangle = a%triangle b%triangle = a%triangle
b%symmetric = a%symmetric b%symmetric = a%symmetric
@ -1225,7 +1225,7 @@ contains
itmp = a%m itmp = a%m
a%m = a%n a%m = a%n
a%n = itmp a%n = itmp
a%state = a%state a%bldstate = a%bldstate
a%duplicate = a%duplicate a%duplicate = a%duplicate
a%triangle = a%triangle a%triangle = a%triangle
a%unitd = a%unitd a%unitd = a%unitd
@ -1402,7 +1402,7 @@ contains
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = a%state res = a%bldstate
end function psb_lbase_get_state end function psb_lbase_get_state
function psb_lbase_get_nrows(a) result(res) function psb_lbase_get_nrows(a) result(res)
@ -1479,7 +1479,7 @@ contains
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
integer(psb_lpk_), intent(in) :: n integer(psb_lpk_), intent(in) :: n
a%state = n a%bldstate = n
end subroutine psb_lbase_set_state end subroutine psb_lbase_set_state
@ -1494,28 +1494,28 @@ contains
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
a%state = psb_spmat_null_ a%bldstate = psb_spmat_null_
end subroutine psb_lbase_set_null end subroutine psb_lbase_set_null
subroutine psb_lbase_set_bld(a) subroutine psb_lbase_set_bld(a)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
a%state = psb_spmat_bld_ a%bldstate = psb_spmat_bld_
end subroutine psb_lbase_set_bld end subroutine psb_lbase_set_bld
subroutine psb_lbase_set_upd(a) subroutine psb_lbase_set_upd(a)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
a%state = psb_spmat_upd_ a%bldstate = psb_spmat_upd_
end subroutine psb_lbase_set_upd end subroutine psb_lbase_set_upd
subroutine psb_lbase_set_asb(a) subroutine psb_lbase_set_asb(a)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
a%state = psb_spmat_asb_ a%bldstate = psb_spmat_asb_
end subroutine psb_lbase_set_asb end subroutine psb_lbase_set_asb
subroutine psb_lbase_set_sorted(a,val) subroutine psb_lbase_set_sorted(a,val)
@ -1652,28 +1652,28 @@ contains
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_null_) res = (a%bldstate == psb_spmat_null_)
end function psb_lbase_is_null end function psb_lbase_is_null
function psb_lbase_is_bld(a) result(res) function psb_lbase_is_bld(a) result(res)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_bld_) res = (a%bldstate == psb_spmat_bld_)
end function psb_lbase_is_bld end function psb_lbase_is_bld
function psb_lbase_is_upd(a) result(res) function psb_lbase_is_upd(a) result(res)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_upd_) res = (a%bldstate == psb_spmat_upd_)
end function psb_lbase_is_upd end function psb_lbase_is_upd
function psb_lbase_is_asb(a) result(res) function psb_lbase_is_asb(a) result(res)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_asb_) res = (a%bldstate == psb_spmat_asb_)
end function psb_lbase_is_asb end function psb_lbase_is_asb
function psb_lbase_is_sorted(a) result(res) function psb_lbase_is_sorted(a) result(res)
@ -1719,7 +1719,7 @@ contains
b%m = a%n b%m = a%n
b%n = a%m b%n = a%m
b%state = a%state b%bldstate = a%bldstate
b%duplicate = a%duplicate b%duplicate = a%duplicate
b%triangle = a%triangle b%triangle = a%triangle
b%unitd = a%unitd b%unitd = a%unitd
@ -1738,7 +1738,7 @@ contains
b%m = a%n b%m = a%n
b%n = a%m b%n = a%m
b%state = a%state b%bldstate = a%bldstate
b%duplicate = a%duplicate b%duplicate = a%duplicate
b%triangle = a%triangle b%triangle = a%triangle
b%unitd = a%unitd b%unitd = a%unitd
@ -1757,7 +1757,7 @@ contains
itmp = a%m itmp = a%m
a%m = a%n a%m = a%n
a%n = itmp a%n = itmp
a%state = a%state a%bldstate = a%bldstate
a%duplicate = a%duplicate a%duplicate = a%duplicate
a%triangle = a%triangle a%triangle = a%triangle
a%unitd = a%unitd a%unitd = a%unitd
@ -1891,7 +1891,7 @@ contains
lb%m = ib%m lb%m = ib%m
lb%n = ib%n lb%n = ib%n
lb%state = ib%state lb%bldstate = ib%bldstate
lb%duplicate = ib%duplicate lb%duplicate = ib%duplicate
lb%triangle = ib%triangle lb%triangle = ib%triangle
lb%unitd = ib%unitd lb%unitd = ib%unitd
@ -1907,7 +1907,7 @@ contains
ib%m = lb%m ib%m = lb%m
ib%n = lb%n ib%n = lb%n
ib%state = lb%state ib%bldstate = lb%bldstate
ib%duplicate = lb%duplicate ib%duplicate = lb%duplicate
ib%triangle = lb%triangle ib%triangle = lb%triangle
ib%unitd = lb%unitd ib%unitd = lb%unitd

335
base/modules/serial/psb_d_base_vect_mod.F90
Unescape Escape View File

@ -65,6 +65,18 @@ module psb_d_base_vect_mod
real(psb_dpk_), allocatable :: v(:) real(psb_dpk_), allocatable :: v(:)
real(psb_dpk_), allocatable :: combuf(:) real(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) 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 contains
! !
! Constructors/allocators ! Constructors/allocators
@ -77,17 +89,30 @@ module psb_d_base_vect_mod
procedure, pass(x) :: mold => d_base_mold procedure, pass(x) :: mold => d_base_mold
! !
! Insert/set. Assembly and free. ! 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_a => d_base_ins_a
procedure, pass(x) :: ins_v => d_base_ins_v procedure, pass(x) :: ins_v => d_base_ins_v
generic, public :: ins => ins_a, ins_v generic, public :: ins => ins_a, ins_v
procedure, pass(x) :: zero => d_base_zero procedure, pass(x) :: zero => d_base_zero
procedure, pass(x) :: asb_m => d_base_asb_m procedure, pass(x) :: asb_m => d_base_asb_m
procedure, pass(x) :: asb_e => d_base_asb_e procedure, pass(x) :: asb_e => d_base_asb_e
generic, public :: asb => asb_m, asb_e generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => d_base_free 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. ! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync ! Any derived class having extra storage upon sync
@ -228,6 +253,7 @@ module psb_d_base_vect_mod
module procedure constructor, size_const module procedure constructor, size_const
end interface psb_d_base_vect end interface psb_d_base_vect
logical, parameter :: try_newins=.true.
contains contains
! !
@ -347,9 +373,28 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,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 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: !> Function base_mold:
!! \memberof psb_d_base_vect_type !! \memberof psb_d_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type !! \brief Mold method: return a variable with the same dynamic type
@ -395,20 +440,77 @@ contains
!! \param info return code !! \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 use psi_serial_mod
implicit none implicit none
class(psb_d_base_vect_type), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0 info = 0
if (psb_errstatus_fatal()) return 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 if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then else if (n > min(size(irl),size(val))) then
@ -445,6 +547,7 @@ contains
! !$ goto 9999 ! !$ goto 9999
end select end select
end if end if
#endif
call x%set_host() call x%set_host()
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -453,11 +556,11 @@ contains
end subroutine d_base_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_d_base_vect_type), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -470,7 +573,7 @@ contains
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%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 if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -521,12 +624,52 @@ contains
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,ncfs,xvsz
real(psb_dpk_), allocatable :: vv(:)
info = 0 info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info) if (try_newins) then
if (info /= 0) & if (x%is_bld()) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine d_base_asb_m end subroutine d_base_asb_m
@ -551,13 +694,54 @@ contains
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
real(psb_dpk_), allocatable :: vv(:)
info = 0 info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info) if (try_newins) then
if (info /= 0) & if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') & 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() call x%sync()
end subroutine d_base_asb_e end subroutine d_base_asb_e
! !
@ -645,6 +829,103 @@ contains
& deallocate(x%comid,stat=info) & deallocate(x%comid,stat=info)
end subroutine d_base_free_comid 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 ! The base version of SYNC & friends does nothing, it's just

139
base/modules/serial/psb_d_vect_mod.F90
Unescape Escape View File

@ -45,9 +45,8 @@ module psb_d_vect_mod
type psb_d_vect_type type psb_d_vect_type
class(psb_d_base_vect_type), allocatable :: v class(psb_d_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0 integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_ integer(psb_ipk_) :: remote_build = psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
real(psb_dpk_), allocatable :: rmtv(:) real(psb_dpk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:) integer(psb_lpk_), allocatable :: rmidx(:)
contains contains
@ -56,14 +55,26 @@ module psb_d_vect_mod
procedure, pass(x) :: get_fmt => d_vect_get_fmt procedure, pass(x) :: get_fmt => d_vect_get_fmt
procedure, pass(x) :: is_remote_build => d_vect_is_remote_build 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) :: 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) :: get_nrmv => d_vect_get_nrmv
procedure, pass(x) :: set_nrmv => d_vect_set_nrmv procedure, pass(x) :: set_nrmv => d_vect_set_nrmv
procedure, pass(x) :: all => d_vect_all procedure, pass(x) :: all => d_vect_all
procedure, pass(x) :: reall => d_vect_reall procedure, pass(x) :: reall => d_vect_reall
procedure, pass(x) :: zero => d_vect_zero procedure, pass(x) :: zero => d_vect_zero
procedure, pass(x) :: asb => d_vect_asb 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) :: gthab => d_vect_gthab
procedure, pass(x) :: gthzv => d_vect_gthzv procedure, pass(x) :: gthzv => d_vect_gthzv
generic, public :: gth => gthab, gthzv generic, public :: gth => gthab, gthzv
@ -194,7 +205,11 @@ contains
implicit none implicit none
class(psb_d_vect_type), intent(in) :: x class(psb_d_vect_type), intent(in) :: x
integer(psb_ipk_) :: res 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 end function d_vect_get_dupl
subroutine d_vect_set_dupl(x,val) subroutine d_vect_set_dupl(x,val)
@ -202,13 +217,93 @@ contains
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then if (allocated(x%v)) then
x%dupl = val if (present(val)) then
else call x%v%set_dupl(val)
x%dupl = psb_dupl_def_ else
call x%v%set_dupl(psb_dupl_def_)
end if
end if end if
end subroutine d_vect_set_dupl 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) function d_vect_get_nrmv(x) result(res)
implicit none implicit none
class(psb_d_vect_type), intent(in) :: x class(psb_d_vect_type), intent(in) :: x
@ -457,8 +552,20 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
call x%set_bld()
end subroutine d_vect_all 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) subroutine d_vect_reall(n, x, info)
implicit none implicit none
@ -547,11 +654,11 @@ contains
end subroutine d_vect_free 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 use psi_serial_mod
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -564,15 +671,15 @@ contains
return return
end if end if
dupl = x%get_dupl() 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 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 use psi_serial_mod
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x 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_i_vect_type), intent(inout) :: irl
class(psb_d_vect_type), intent(inout) :: val class(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -585,7 +692,7 @@ contains
return return
end if end if
dupl = x%get_dupl() 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 end subroutine d_vect_ins_v

8
base/modules/tools/psb_d_tools_mod.F90
Unescape Escape View File

@ -70,7 +70,7 @@ Module psb_d_tools_mod
interface psb_geasb 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 import
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -78,6 +78,7 @@ Module psb_d_tools_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dasb_vect end subroutine psb_dasb_vect
subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch) subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch)
import import
@ -250,16 +251,17 @@ Module psb_d_tools_mod
end interface end interface
interface psb_spasb 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 import
implicit none implicit none
type(psb_dspmat_type), intent (inout) :: a type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info 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 character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dspasb end subroutine psb_dspasb
end interface end interface

7
base/tools/psb_dallc.f90
Unescape Escape View File

@ -111,10 +111,11 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode)
end if end if
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl dupl_ = dupl
else !!$ else
dupl_ = psb_dupl_def_ !!$ dupl_ = psb_dupl_def_
end if 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_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

114
base/tools/psb_dasb.f90
Unescape Escape View File

@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents. ! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false. ! 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 use psb_base_mod, psb_protect_name => psb_dasb_vect
implicit none implicit none
@ -60,6 +60,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables ! local variables
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -68,6 +69,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
logical :: scratch_ logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
!logical, parameter :: try_newins = .true.
info = psb_success_ info = psb_success_
name = 'psb_dgeasb_v' name = 'psb_dgeasb_v'
@ -83,7 +85,6 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
scratch_ = .false. scratch_ = .false.
if (present(scratch)) scratch_ = scratch if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np) call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
@ -99,41 +100,88 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (try_newins) then
if (scratch_) then !!$ if (present(dupl)) then
call x%free(info) !!$ call x%set_dupl(dupl)
call x%bld(ncol,mold=mold) !!$ end if
else dupl_ = x%get_dupl()
if (x%is_remote_build()) then if (scratch_) then
block call x%free(info)
integer(psb_lpk_), allocatable :: lvx(:) call x%bld(ncol,mold=mold)
real(psb_dpk_), allocatable :: vx(:) else
integer(psb_ipk_), allocatable :: ivx(:) if (x%is_bld().and.present(dupl)) then
integer(psb_ipk_) :: nrmv, nx, i call x%set_dupl(dupl)
dupl_ = dupl
nrmv = x%get_nrmv() end if
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) if (x%is_remote_build()) then
nx = size(vx) block
call psb_realloc(nx,ivx,info) integer(psb_lpk_), allocatable :: lvx(:)
call desc_a%g2l(lvx,ivx,info,owned=.true.) real(psb_dpk_), allocatable :: vx(:)
call x%ins(nx,ivx,vx,info) integer(psb_ipk_), allocatable :: ivx(:)
end block 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 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) if (scratch_) then
! ..update halo elements.. call x%free(info)
call psb_halo(x,desc_a,info) call x%bld(ncol,mold=mold)
if(info /= psb_success_) then else
info=psb_err_from_subroutine_ if (x%is_bld().and.present(dupl)) then
call psb_errpush(info,name,a_err='psb_halo') !!$ call x%set_dupl(dupl)
goto 9999 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 end if
call x%cnv(mold) if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

6
base/tools/psb_dins.f90
Unescape Escape View File

@ -127,7 +127,7 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,info) call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 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.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,info) call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -368,7 +368,7 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ 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 if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then

12
base/tools/psb_dspasb.f90
Unescape Escape View File

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory) ! 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_base_mod, psb_protect_name => psb_dspasb
use psb_sort_mod use psb_sort_mod
use psi_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 character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
!....Locals.... !....Locals....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act 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 !check on errors encountered in psdspins
if (a%is_bld()) then 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. ! 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 if (bld_and_) then
!!$ allocate(a%ad,mold=a%a) !!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o !!$ 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 !!$ block
!!$ character(len=1024) :: fname !!$ character(len=1024) :: fname
!!$ type(psb_d_coo_sparse_mat) :: acoo !!$ type(psb_d_coo_sparse_mat) :: acoo

6
base/tools/psb_dspins.F90
Unescape Escape View File

@ -138,7 +138,11 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then 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 if (local_) then
info = psb_err_invalid_a_and_cd_state_ info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)

12
cuda/psb_d_cuda_vect_mod.F90
Unescape Escape View File

@ -1252,11 +1252,11 @@ contains
call x%free(info) call x%free(info)
end subroutine d_cuda_vect_finalize 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 use psi_serial_mod
implicit none implicit none
class(psb_d_vect_cuda), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1285,7 @@ contains
if (.not.done_cuda) then if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%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 end if
if (info /= 0) then if (info /= 0) then
@ -1295,11 +1295,11 @@ contains
end subroutine d_cuda_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_d_vect_cuda), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1308,7 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine d_cuda_ins_a end subroutine d_cuda_ins_a

12
openacc/psb_d_oacc_vect_mod.F90
Unescape Escape View File

@ -620,11 +620,11 @@ contains
end subroutine inner_gth end subroutine inner_gth
end subroutine d_oacc_gthzv_x 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 use psi_serial_mod
implicit none implicit none
class(psb_d_vect_oacc), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_d_vect_oacc) type is (psb_d_vect_oacc)
if (vval%is_dev()) call vval%sync() if (vval%is_dev()) call vval%sync()
end select 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 end if
if (info /= 0) then if (info /= 0) then
@ -671,11 +671,11 @@ contains
end subroutine d_oacc_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_d_vect_oacc), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -684,7 +684,7 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()

8
test/pdegen/psb_d_pde3d.F90
Unescape Escape View File

@ -606,9 +606,9 @@ contains
t1 = psb_wtime() t1 = psb_wtime()
if (info == psb_success_) then if (info == psb_success_) then
if (present(amold)) 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 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
end if end if
call psb_barrier(ctxt) call psb_barrier(ctxt)
@ -618,8 +618,8 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (info == psb_success_) call psb_geasb(xv,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) if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='asb rout.' ch_err='asb rout.'

Write Preview
Loading…
Cancel
Save