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

Merge branch 'fix-build' into development

Browse Source
gpucinterfaces
sfilippone 6 months ago
parent 3983255f9f a401f60215
commit 9552bda6de
75 changed files with 5497 additions and 931 deletions
Show Stats Download Patch File Download Diff File

9
base/modules/psb_config.h.in
Unescape Escape View File

@ -9,6 +9,15 @@
#define PSB_VERSION_PATCHLEVEL @PSBLASPATCH@
#define PSB_VERSION_STRING @PSBLASSTRING@
#define PSB_DUPL_NULL @PSBLASDUPNUL@
#define PSB_DUPL_ADD @PSBLASDUPADD@
#define PSB_DUPL_OVWRT @PSBLASDUPOVW@
#define PSB_DUPL_ERR @PSBLASDUPERR@
#define PSB_DUPL_DEF @PSBLASDUPDEF@
#define PSB_MATBLD_NOREMOTE @PSBLASBLDNOR@
#define PSB_MATBLD_REMOTE @PSBLASBLDRMT@
@CSERIALMPI@
@PSB_IPKDEF@

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

@ -203,13 +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
integer(psb_ipk_), parameter :: 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
@ -223,9 +226,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
@ -329,7 +333,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)

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.
!! 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

455
base/modules/serial/psb_c_base_vect_mod.F90
Unescape Escape View File

@ -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,22 @@ 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
procedure, pass(x) :: base_cpy => c_base_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -211,8 +239,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 +289,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 +329,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 +354,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 +390,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 +458,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 +577,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 +594,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 +638,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine c_base_asb_m
@ -537,19 +721,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine c_base_asb_e
@ -572,9 +809,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 +875,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
@ -733,6 +1068,24 @@ contains
res = .true.
end function c_base_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine c_base_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_c_base_vect_type), intent(in) :: x
class(psb_c_base_vect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine c_base_cpy
!
! Size info.

206
base/modules/serial/psb_c_vect_mod.F90
Unescape Escape View File

@ -56,14 +56,28 @@ 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_ncfs => c_vect_set_ncfs
procedure, pass(x) :: get_ncfs => c_vect_get_ncfs
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 +201,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_dupl()
else
res = psb_dupl_null_
end if
end function c_vect_get_dupl
subroutine c_vect_set_dupl(x,val)
@ -195,13 +213,117 @@ 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_ncfs(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_ncfs()
else
res = 0
end if
end function c_vect_get_ncfs
subroutine c_vect_set_ncfs(x,val)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_ncfs(val)
else
call x%v%set_ncfs(0)
end if
end if
end subroutine c_vect_set_ncfs
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
@ -216,7 +338,6 @@ contains
x%nrmv = val
end subroutine c_vect_set_nrmv
function c_vect_is_remote_build(x) result(res)
implicit none
@ -287,16 +408,25 @@ contains
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
allocate(y%v,source=x%v, stat=info)
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 +437,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 +466,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 +494,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 +596,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 +633,18 @@ 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)
call x%set_asb()
end if
end subroutine c_vect_asb
@ -540,11 +699,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 +716,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 +737,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
@ -600,6 +759,7 @@ contains
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info)
endif
end if

455
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 :: 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,22 @@ module psb_d_base_vect_mod
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
procedure, pass(x) :: base_cpy => d_base_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -218,8 +246,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
@ -270,14 +296,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')
@ -302,15 +336,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
@ -319,15 +361,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
@ -347,9 +397,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 d_base_all
subroutine d_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = dzero
call x%set_host()
call x%set_upd()
end if
end subroutine d_base_reinit
!> Function base_mold:
!! \memberof psb_d_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@ -395,55 +465,116 @@ 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
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)
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)
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 +584,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 +601,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 +645,72 @@ 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
logical, intent(in), optional :: scratch
logical :: scratch_
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 (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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine d_base_asb_m
@ -544,19 +728,72 @@ 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
logical, intent(in), optional :: scratch
logical :: scratch_
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 (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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine d_base_asb_e
@ -579,9 +816,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
@ -644,7 +882,104 @@ 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
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
@ -740,6 +1075,24 @@ contains
res = .true.
end function d_base_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine d_base_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_base_vect_type), intent(in) :: x
class(psb_d_base_vect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine d_base_cpy
!
! Size info.

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

@ -56,14 +56,28 @@ 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_ncfs => d_vect_set_ncfs
procedure, pass(x) :: get_ncfs => d_vect_get_ncfs
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 +208,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_dupl()
else
res = psb_dupl_null_
end if
end function d_vect_get_dupl
subroutine d_vect_set_dupl(x,val)
@ -202,13 +220,117 @@ 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_ncfs(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_ncfs()
else
res = 0
end if
end function d_vect_get_ncfs
subroutine d_vect_set_ncfs(x,val)
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_ncfs(val)
else
call x%v%set_ncfs(0)
end if
end if
end subroutine d_vect_set_ncfs
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
@ -223,7 +345,6 @@ contains
x%nrmv = val
end subroutine d_vect_set_nrmv
function d_vect_is_remote_build(x) result(res)
implicit none
@ -294,16 +415,25 @@ contains
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
allocate(y%v,source=x%v, stat=info)
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)
@ -314,17 +444,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)) &
@ -335,17 +473,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)
@ -355,7 +501,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
@ -457,8 +603,19 @@ 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
@ -483,16 +640,18 @@ 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)
call x%set_asb()
end if
end subroutine d_vect_asb
@ -547,11 +706,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 +723,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 +744,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
@ -607,6 +766,7 @@ contains
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info)
endif
end if

457
base/modules/serial/psb_i_base_vect_mod.F90
Unescape Escape View File

@ -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,22 @@ 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
procedure, pass(x) :: base_cpy => i_base_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -144,8 +172,6 @@ module psb_i_base_vect_mod
end type psb_i_base_vect_type
public :: psb_i_base_vect
@ -196,14 +222,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 +262,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 +287,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 +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 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 +391,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 +510,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 +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')
@ -440,19 +571,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine i_base_asb_m
@ -470,19 +654,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine i_base_asb_e
@ -505,9 +742,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 +808,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
@ -666,6 +1001,24 @@ contains
res = .true.
end function i_base_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine i_base_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_base_vect_type), intent(in) :: x
class(psb_i_base_vect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine i_base_cpy
!
! Size info.

206
base/modules/serial/psb_i_vect_mod.F90
Unescape Escape View File

@ -55,14 +55,28 @@ 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_ncfs => i_vect_set_ncfs
procedure, pass(x) :: get_ncfs => i_vect_get_ncfs
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 +146,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_dupl()
else
res = psb_dupl_null_
end if
end function i_vect_get_dupl
subroutine i_vect_set_dupl(x,val)
@ -140,13 +158,117 @@ 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_ncfs(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_ncfs()
else
res = 0
end if
end function i_vect_get_ncfs
subroutine i_vect_set_ncfs(x,val)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_ncfs(val)
else
call x%v%set_ncfs(0)
end if
end if
end subroutine i_vect_set_ncfs
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
@ -161,7 +283,6 @@ contains
x%nrmv = val
end subroutine i_vect_set_nrmv
function i_vect_is_remote_build(x) result(res)
implicit none
@ -232,16 +353,25 @@ contains
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
allocate(y%v,source=x%v, stat=info)
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 +382,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 +411,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 +439,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 +541,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 +578,18 @@ 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)
call x%set_asb()
end if
end subroutine i_vect_asb
@ -485,11 +644,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 +661,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 +682,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
@ -545,6 +704,7 @@ contains
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info)
endif
end if

457
base/modules/serial/psb_l_base_vect_mod.F90
Unescape Escape View File

@ -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,22 @@ 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
procedure, pass(x) :: base_cpy => l_base_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -145,8 +173,6 @@ module psb_l_base_vect_mod
end type psb_l_base_vect_type
public :: psb_l_base_vect
@ -197,14 +223,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 +263,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 +288,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 +324,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 +392,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 +511,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 +528,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 +572,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine l_base_asb_m
@ -471,19 +655,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine l_base_asb_e
@ -506,9 +743,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 +809,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
@ -667,6 +1002,24 @@ contains
res = .true.
end function l_base_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine l_base_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_l_base_vect_type), intent(in) :: x
class(psb_l_base_vect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine l_base_cpy
!
! Size info.

206
base/modules/serial/psb_l_vect_mod.F90
Unescape Escape View File

@ -56,14 +56,28 @@ 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_ncfs => l_vect_set_ncfs
procedure, pass(x) :: get_ncfs => l_vect_get_ncfs
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 +147,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_dupl()
else
res = psb_dupl_null_
end if
end function l_vect_get_dupl
subroutine l_vect_set_dupl(x,val)
@ -141,13 +159,117 @@ 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_ncfs(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_ncfs()
else
res = 0
end if
end function l_vect_get_ncfs
subroutine l_vect_set_ncfs(x,val)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_ncfs(val)
else
call x%v%set_ncfs(0)
end if
end if
end subroutine l_vect_set_ncfs
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
@ -162,7 +284,6 @@ contains
x%nrmv = val
end subroutine l_vect_set_nrmv
function l_vect_is_remote_build(x) result(res)
implicit none
@ -233,16 +354,25 @@ contains
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
allocate(y%v,source=x%v, stat=info)
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 +383,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 +412,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 +440,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 +542,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 +579,18 @@ 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)
call x%set_asb()
end if
end subroutine l_vect_asb
@ -486,11 +645,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 +662,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 +683,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
@ -546,6 +705,7 @@ contains
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info)
endif
end if

455
base/modules/serial/psb_s_base_vect_mod.F90
Unescape Escape View File

@ -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,22 @@ 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
procedure, pass(x) :: base_cpy => s_base_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -218,8 +246,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 +296,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 +336,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 +361,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 +397,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 +465,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 +584,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 +601,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 +645,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine s_base_asb_m
@ -544,19 +728,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine s_base_asb_e
@ -579,9 +816,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 +882,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
@ -740,6 +1075,24 @@ contains
res = .true.
end function s_base_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine s_base_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_s_base_vect_type), intent(in) :: x
class(psb_s_base_vect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine s_base_cpy
!
! Size info.

206
base/modules/serial/psb_s_vect_mod.F90
Unescape Escape View File

@ -56,14 +56,28 @@ 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_ncfs => s_vect_set_ncfs
procedure, pass(x) :: get_ncfs => s_vect_get_ncfs
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 +208,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_dupl()
else
res = psb_dupl_null_
end if
end function s_vect_get_dupl
subroutine s_vect_set_dupl(x,val)
@ -202,13 +220,117 @@ 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_ncfs(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_ncfs()
else
res = 0
end if
end function s_vect_get_ncfs
subroutine s_vect_set_ncfs(x,val)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_ncfs(val)
else
call x%v%set_ncfs(0)
end if
end if
end subroutine s_vect_set_ncfs
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
@ -223,7 +345,6 @@ contains
x%nrmv = val
end subroutine s_vect_set_nrmv
function s_vect_is_remote_build(x) result(res)
implicit none
@ -294,16 +415,25 @@ contains
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
allocate(y%v,source=x%v, stat=info)
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 +444,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 +473,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 +501,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 +603,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 +640,18 @@ 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)
call x%set_asb()
end if
end subroutine s_vect_asb
@ -547,11 +706,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 +723,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 +744,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
@ -607,6 +766,7 @@ contains
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info)
endif
end if

455
base/modules/serial/psb_z_base_vect_mod.F90
Unescape Escape View File

@ -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,22 @@ 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
procedure, pass(x) :: base_cpy => z_base_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -211,8 +239,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 +289,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 +329,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 +354,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 +390,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 +458,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 +577,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 +594,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 +638,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine z_base_asb_m
@ -537,19 +721,72 @@ 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.x%is_asb().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%set_host()
call x%set_asb()
call x%sync()
end subroutine z_base_asb_e
@ -572,9 +809,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 +875,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
@ -733,6 +1068,24 @@ contains
res = .true.
end function z_base_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine z_base_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_z_base_vect_type), intent(in) :: x
class(psb_z_base_vect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine z_base_cpy
!
! Size info.

206
base/modules/serial/psb_z_vect_mod.F90
Unescape Escape View File

@ -56,14 +56,28 @@ 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_ncfs => z_vect_set_ncfs
procedure, pass(x) :: get_ncfs => z_vect_get_ncfs
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 +201,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_dupl()
else
res = psb_dupl_null_
end if
end function z_vect_get_dupl
subroutine z_vect_set_dupl(x,val)
@ -195,13 +213,117 @@ 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_ncfs(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_ncfs()
else
res = 0
end if
end function z_vect_get_ncfs
subroutine z_vect_set_ncfs(x,val)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_ncfs(val)
else
call x%v%set_ncfs(0)
end if
end if
end subroutine z_vect_set_ncfs
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
@ -216,7 +338,6 @@ contains
x%nrmv = val
end subroutine z_vect_set_nrmv
function z_vect_is_remote_build(x) result(res)
implicit none
@ -287,16 +408,25 @@ contains
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
allocate(y%v,source=x%v, stat=info)
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 +437,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 +466,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 +494,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 +596,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 +633,18 @@ 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)
call x%set_asb()
end if
end subroutine z_vect_asb
@ -540,11 +699,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 +716,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 +737,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
@ -600,6 +759,7 @@ contains
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info)
endif
end if

6
base/modules/tools/psb_c_tools_mod.F90
Unescape Escape View File

@ -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

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

@ -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,13 +251,14 @@ 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) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and

3
base/modules/tools/psb_i_tools_mod.F90
Unescape Escape View File

@ -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

3
base/modules/tools/psb_l_tools_mod.F90
Unescape Escape View File

@ -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

6
base/modules/tools/psb_s_tools_mod.F90
Unescape Escape View File

@ -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

6
base/modules/tools/psb_z_tools_mod.F90
Unescape Escape View File

@ -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

11
base/tools/psb_callc.f90
Unescape Escape View File

@ -95,8 +95,7 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode)
goto 9999
endif
allocate(psb_c_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@ -109,12 +108,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

110
base/tools/psb_casb.f90
Unescape Escape View File

@ -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)

10
base/tools/psb_cins.f90
Unescape Escape View File

@ -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

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

@ -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

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

@ -95,8 +95,7 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode)
goto 9999
endif
allocate(psb_d_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@ -109,12 +108,10 @@ subroutine psb_dalloc_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

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

@ -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
@ -80,10 +81,9 @@ subroutine psb_dasb_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_dasb_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_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(:)
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
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_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_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)

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

@ -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
@ -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
@ -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
@ -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

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

@ -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

11
base/tools/psb_iallc.f90
Unescape Escape View File

@ -95,8 +95,7 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode)
goto 9999
endif
allocate(psb_i_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@ -109,12 +108,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

110
base/tools/psb_iasb.f90
Unescape Escape View File

@ -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)

10
base/tools/psb_iins.f90
Unescape Escape View File

@ -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

11
base/tools/psb_lallc.f90
Unescape Escape View File

@ -95,8 +95,7 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode)
goto 9999
endif
allocate(psb_l_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@ -109,12 +108,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

110
base/tools/psb_lasb.f90
Unescape Escape View File

@ -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)

10
base/tools/psb_lins.f90
Unescape Escape View File

@ -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

11
base/tools/psb_sallc.f90
Unescape Escape View File

@ -95,8 +95,7 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode)
goto 9999
endif
allocate(psb_s_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@ -109,12 +108,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

110
base/tools/psb_sasb.f90
Unescape Escape View File

@ -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)

10
base/tools/psb_sins.f90
Unescape Escape View File

@ -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

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

@ -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

11
base/tools/psb_zallc.f90
Unescape Escape View File

@ -95,8 +95,7 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode)
goto 9999
endif
allocate(psb_z_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@ -109,12 +108,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

110
base/tools/psb_zasb.f90
Unescape Escape View File

@ -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)

10
base/tools/psb_zins.f90
Unescape Escape View File

@ -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

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

@ -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

4
cbind/base/psb_c_cbase.h
Unescape Escape View File

@ -22,14 +22,18 @@ psb_c_t *psb_c_cvect_get_cpy( psb_c_cvector *xh);
psb_i_t psb_c_cvect_f_get_cpy(psb_c_t *v, psb_c_cvector *xh);
psb_i_t psb_c_cvect_zero(psb_c_cvector *xh);
psb_i_t *psb_c_cvect_f_get_pnt(psb_c_cvector *xh);
psb_i_t psb_c_cvect_clone(psb_c_cvector *xh,psb_c_cvector *yh);
psb_i_t psb_c_cgeall(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeall_remote(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeall_remote_options(psb_c_cvector *xh, psb_c_descriptor *cdh,
psb_i_t bldmode, psb_i_t duple);
psb_i_t psb_c_cgeins(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val,
psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val,
psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeasb(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeasb_options(psb_c_cvector *xh, psb_c_descriptor *cdh, psb_i_t dupl);
psb_i_t psb_c_cgefree(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_c_t psb_c_cgetelem(psb_c_cvector *xh,psb_l_t index,psb_c_descriptor *cd);

4
cbind/base/psb_c_dbase.h
Unescape Escape View File

@ -22,14 +22,18 @@ psb_d_t *psb_c_dvect_get_cpy( psb_c_dvector *xh);
psb_i_t psb_c_dvect_f_get_cpy(psb_d_t *v, psb_c_dvector *xh);
psb_i_t psb_c_dvect_zero(psb_c_dvector *xh);
psb_d_t *psb_c_dvect_f_get_pnt( psb_c_dvector *xh);
psb_i_t psb_c_dvect_clone(psb_c_dvector *xh,psb_c_dvector *yh);
psb_i_t psb_c_dgeall(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeall_remote(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeall_remote_options(psb_c_dvector *xh, psb_c_descriptor *cdh,
psb_i_t bldmode, psb_i_t duple);
psb_i_t psb_c_dgeins(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val,
psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val,
psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeasb(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeasb_options(psb_c_dvector *xh, psb_c_descriptor *cdh, psb_i_t dupl);
psb_i_t psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_dgetelem(psb_c_dvector *xh,psb_l_t index,psb_c_descriptor *cd);

4
cbind/base/psb_c_sbase.h
Unescape Escape View File

@ -22,14 +22,18 @@ psb_s_t *psb_c_svect_get_cpy( psb_c_svector *xh);
psb_i_t psb_c_svect_f_get_cpy(psb_s_t *v, psb_c_svector *xh);
psb_i_t psb_c_svect_zero(psb_c_svector *xh);
psb_s_t *psb_c_svect_f_get_pnt( psb_c_svector *xh);
psb_i_t psb_c_svect_clone(psb_c_svector *xh,psb_c_svector *yh);
psb_i_t psb_c_sgeall(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeall_remote(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeall_remote_options(psb_c_svector *xh, psb_c_descriptor *cdh,
psb_i_t bldmode, psb_i_t duple);
psb_i_t psb_c_sgeins(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val,
psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val,
psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeasb(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeasb_options(psb_c_svector *xh, psb_c_descriptor *cdh, psb_i_t dupl);
psb_i_t psb_c_sgefree(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_sgetelem(psb_c_svector *xh,psb_l_t index,psb_c_descriptor *cd);

24
cbind/base/psb_c_serial_cbind_mod.F90
Unescape Escape View File

@ -205,4 +205,28 @@ contains
end function psb_c_cvect_set_vect
function psb_c_cvect_clone(xh,yh) bind(c) result(info)
implicit none
integer(psb_c_ipk_) :: info
type(psb_c_cvector) :: xh,yh
type(psb_c_vect_type), pointer :: xp,yp
info = -1
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
if (c_associated(yh%item)) then
call c_f_pointer(yh%item,yp)
else
return
end if
call xp%clone(yp,info)
end function psb_c_cvect_clone
end module psb_c_serial_cbind_mod

64
cbind/base/psb_c_tools_cbind_mod.F90
Unescape Escape View File

@ -67,6 +67,38 @@ contains
return
end function psb_c_cgeall_remote
function psb_c_cgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cvector) :: xh
type(psb_c_descriptor) :: cdh
integer(psb_c_ipk_), value :: dupl
integer(psb_c_ipk_), value :: bldmode
type(psb_desc_type), pointer :: descp
type(psb_c_vect_type), pointer :: xp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
return
end if
allocate(xp)
call psb_geall(xp,descp,info,bldmode=bldmode,dupl=dupl)
xh%item = c_loc(xp)
res = min(0,info)
return
end function psb_c_cgeall_remote_options
function psb_c_cgeasb(xh,cdh) bind(c) result(res)
implicit none
@ -97,6 +129,38 @@ contains
return
end function psb_c_cgeasb
function psb_c_cgeasb_options(xh,cdh,dupl) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_cvector) :: xh
type(psb_c_descriptor) :: cdh
integer(psb_c_ipk_), value :: dupl
type(psb_desc_type), pointer :: descp
type(psb_d_vect_type), pointer :: xp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
call psb_geasb(xp,descp,info,dupl=dupl)
res = min(0,info)
return
end function psb_c_cgeasb_options
function psb_c_cgefree(xh,cdh) bind(c) result(res)
implicit none

4
cbind/base/psb_c_zbase.h
Unescape Escape View File

@ -22,14 +22,18 @@ psb_z_t *psb_c_zvect_get_cpy( psb_c_zvector *xh);
psb_i_t psb_c_zvect_f_get_cpy(psb_z_t *v, psb_c_zvector *xh);
psb_i_t psb_c_zvect_zero(psb_c_zvector *xh);
psb_z_t *psb_c_zvect_f_get_pnt( psb_c_zvector *xh);
psb_i_t psb_c_zvect_clone(psb_c_zvector *xh,psb_c_zvector *yh);
psb_i_t psb_c_zgeall(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeall_remote(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeall_remote_options(psb_c_zvector *xh, psb_c_descriptor *cdh,
psb_i_t bldmode, psb_i_t duple);
psb_i_t psb_c_zgeins(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val,
psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val,
psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeasb(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeasb_options(psb_c_zvector *xh, psb_c_descriptor *cdh, psb_i_t dupl);
psb_i_t psb_c_zgefree(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_z_t psb_c_zgetelem(psb_c_zvector *xh,psb_l_t index,psb_c_descriptor *cd);

24
cbind/base/psb_d_serial_cbind_mod.F90
Unescape Escape View File

@ -205,4 +205,28 @@ contains
end function psb_c_dvect_set_vect
function psb_c_dvect_clone(xh,yh) bind(c) result(info)
implicit none
integer(psb_c_ipk_) :: info
type(psb_c_dvector) :: xh,yh
type(psb_d_vect_type), pointer :: xp,yp
info = -1
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
if (c_associated(yh%item)) then
call c_f_pointer(yh%item,yp)
else
return
end if
call xp%clone(yp,info)
end function psb_c_dvect_clone
end module psb_d_serial_cbind_mod

64
cbind/base/psb_d_tools_cbind_mod.F90
Unescape Escape View File

@ -67,6 +67,38 @@ contains
return
end function psb_c_dgeall_remote
function psb_c_dgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dvector) :: xh
type(psb_c_descriptor) :: cdh
integer(psb_c_ipk_), value :: dupl
integer(psb_c_ipk_), value :: bldmode
type(psb_desc_type), pointer :: descp
type(psb_d_vect_type), pointer :: xp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
return
end if
allocate(xp)
call psb_geall(xp,descp,info,bldmode=bldmode,dupl=dupl)
xh%item = c_loc(xp)
res = min(0,info)
return
end function psb_c_dgeall_remote_options
function psb_c_dgeasb(xh,cdh) bind(c) result(res)
implicit none
@ -97,6 +129,38 @@ contains
return
end function psb_c_dgeasb
function psb_c_dgeasb_options(xh,cdh,dupl) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_dvector) :: xh
type(psb_c_descriptor) :: cdh
integer(psb_c_ipk_), value :: dupl
type(psb_desc_type), pointer :: descp
type(psb_d_vect_type), pointer :: xp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
call psb_geasb(xp,descp,info,dupl=dupl)
res = min(0,info)
return
end function psb_c_dgeasb_options
function psb_c_dgefree(xh,cdh) bind(c) result(res)
implicit none

24
cbind/base/psb_s_serial_cbind_mod.F90
Unescape Escape View File

@ -205,4 +205,28 @@ contains
end function psb_c_svect_set_vect
function psb_c_svect_clone(xh,yh) bind(c) result(info)
implicit none
integer(psb_c_ipk_) :: info
type(psb_c_svector) :: xh,yh
type(psb_s_vect_type), pointer :: xp,yp
info = -1
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
if (c_associated(yh%item)) then
call c_f_pointer(yh%item,yp)
else
return
end if
call xp%clone(yp,info)
end function psb_c_svect_clone
end module psb_s_serial_cbind_mod

64
cbind/base/psb_s_tools_cbind_mod.F90
Unescape Escape View File

@ -67,6 +67,38 @@ contains
return
end function psb_c_sgeall_remote
function psb_c_sgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_svector) :: xh
type(psb_c_descriptor) :: cdh
integer(psb_c_ipk_), value :: dupl
integer(psb_c_ipk_), value :: bldmode
type(psb_desc_type), pointer :: descp
type(psb_s_vect_type), pointer :: xp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
return
end if
allocate(xp)
call psb_geall(xp,descp,info,bldmode=bldmode,dupl=dupl)
xh%item = c_loc(xp)
res = min(0,info)
return
end function psb_c_sgeall_remote_options
function psb_c_sgeasb(xh,cdh) bind(c) result(res)
implicit none
@ -97,6 +129,38 @@ contains
return
end function psb_c_sgeasb
function psb_c_sgeasb_options(xh,cdh,dupl) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_svector) :: xh
type(psb_c_descriptor) :: cdh
integer(psb_c_ipk_), value :: dupl
type(psb_desc_type), pointer :: descp
type(psb_d_vect_type), pointer :: xp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
call psb_geasb(xp,descp,info,dupl=dupl)
res = min(0,info)
return
end function psb_c_sgeasb_options
function psb_c_sgefree(xh,cdh) bind(c) result(res)
implicit none

24
cbind/base/psb_z_serial_cbind_mod.F90
Unescape Escape View File

@ -205,4 +205,28 @@ contains
end function psb_c_zvect_set_vect
function psb_c_zvect_clone(xh,yh) bind(c) result(info)
implicit none
integer(psb_c_ipk_) :: info
type(psb_c_zvector) :: xh,yh
type(psb_z_vect_type), pointer :: xp,yp
info = -1
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
if (c_associated(yh%item)) then
call c_f_pointer(yh%item,yp)
else
return
end if
call xp%clone(yp,info)
end function psb_c_zvect_clone
end module psb_z_serial_cbind_mod

64
cbind/base/psb_z_tools_cbind_mod.F90
Unescape Escape View File

@ -67,6 +67,38 @@ contains
return
end function psb_c_zgeall_remote
function psb_c_zgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zvector) :: xh
type(psb_c_descriptor) :: cdh
integer(psb_c_ipk_), value :: dupl
integer(psb_c_ipk_), value :: bldmode
type(psb_desc_type), pointer :: descp
type(psb_z_vect_type), pointer :: xp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
return
end if
allocate(xp)
call psb_geall(xp,descp,info,bldmode=bldmode,dupl=dupl)
xh%item = c_loc(xp)
res = min(0,info)
return
end function psb_c_zgeall_remote_options
function psb_c_zgeasb(xh,cdh) bind(c) result(res)
implicit none
@ -97,6 +129,38 @@ contains
return
end function psb_c_zgeasb
function psb_c_zgeasb_options(xh,cdh,dupl) bind(c) result(res)
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_zvector) :: xh
type(psb_c_descriptor) :: cdh
integer(psb_c_ipk_), value :: dupl
type(psb_desc_type), pointer :: descp
type(psb_d_vect_type), pointer :: xp
integer(psb_c_ipk_) :: info
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
call psb_geasb(xp,descp,info,dupl=dupl)
res = min(0,info)
return
end function psb_c_zgeasb_options
function psb_c_zgefree(xh,cdh) bind(c) result(res)
implicit none

135
cbind/psb_c_base.h
Unescape Escape View File

@ -0,0 +1,135 @@
#ifndef PSB_C_BASE__
#define PSB_C_BASE__
#ifdef __cplusplus
extern "C" {
/*typedef char _Bool;*/
#endif
#include <float.h>
#ifdef __cplusplus
#include <complex>
#else
#include <complex.h>
#endif
#include <stdint.h>
#include <stddef.h>
#include <stdlib.h>
#include <stdio.h>
#include <stdbool.h>
#include "psb_config.h"
#include "psb_types.h"
typedef struct PSB_C_DESCRIPTOR {
void *descriptor;
} psb_c_descriptor;
typedef struct PSB_C_CTXT {
psb_i_t *ctxt;
} psb_c_ctxt;
void psb_c_check_error(psb_c_ctxt cctxt);
psb_i_t psb_c_error();
psb_i_t psb_c_clean_errstack();
void psb_c_print_errmsg();
char *psb_c_pop_errmsg();
psb_i_t psb_c_f2c_errmsg(char *, psb_i_t);
void psb_c_seterraction_ret();
void psb_c_seterraction_print();
void psb_c_seterraction_abort();
/* Environment routines */
void psb_c_init(psb_c_ctxt *cctxt);
void psb_c_init_from_fint(psb_c_ctxt *cctxt, psb_i_t f_comm);
void psb_c_exit(psb_c_ctxt cctxt);
void psb_c_exit_ctxt(psb_c_ctxt cctxt);
void psb_c_abort(psb_c_ctxt cctxt);
void psb_c_barrier(psb_c_ctxt cctxt);
void psb_c_info(psb_c_ctxt cctxt, psb_i_t *iam, psb_i_t *np);
void psb_c_get_i_ctxt(psb_c_ctxt cctxt, psb_i_t *ictxt, psb_i_t *info);
bool psb_c_cmp_ctxt(psb_c_ctxt cctxt1, psb_c_ctxt cctxt2);
psb_d_t psb_c_wtime();
psb_i_t psb_c_get_errstatus();
psb_i_t psb_c_get_index_base();
void psb_c_set_index_base(psb_i_t base);
void psb_c_mbcast(psb_c_ctxt cctxt, psb_i_t n, psb_m_t *v, psb_i_t root);
void psb_c_ibcast(psb_c_ctxt cctxt, psb_i_t n, psb_i_t *v, psb_i_t root);
void psb_c_lbcast(psb_c_ctxt cctxt, psb_i_t n, psb_l_t *v, psb_i_t root);
void psb_c_ebcast(psb_c_ctxt cctxt, psb_i_t n, psb_e_t *v, psb_i_t root);
void psb_c_sbcast(psb_c_ctxt cctxt, psb_i_t n, psb_s_t *v, psb_i_t root);
void psb_c_dbcast(psb_c_ctxt cctxt, psb_i_t n, psb_d_t *v, psb_i_t root);
void psb_c_cbcast(psb_c_ctxt cctxt, psb_i_t n, psb_c_t *v, psb_i_t root);
void psb_c_zbcast(psb_c_ctxt cctxt, psb_i_t n, psb_z_t *v, psb_i_t root);
void psb_c_hbcast(psb_c_ctxt cctxt, const char *v, psb_i_t root);
/* Descriptor/integer routines */
psb_c_descriptor* psb_c_new_descriptor();
void psb_c_delete_descriptor(psb_c_descriptor *);
psb_c_ctxt* psb_c_new_ctxt();
void psb_c_delete_ctxt(psb_c_ctxt *);
psb_i_t psb_c_cdall_vg(psb_l_t ng, psb_i_t *vg, psb_c_ctxt cctxt, psb_c_descriptor *cd);
psb_i_t psb_c_cdall_vl(psb_i_t nl, psb_l_t *vl, psb_c_ctxt cctxt, psb_c_descriptor *cd);
psb_i_t psb_c_cdall_vl_lidx(psb_i_t nl, psb_l_t *vl, psb_i_t *lidx, psb_c_ctxt cctxt, psb_c_descriptor *cd);
psb_i_t psb_c_cdall_nl(psb_i_t nl, psb_c_ctxt cctxt, psb_c_descriptor *cd);
psb_i_t psb_c_cdall_repl(psb_l_t n, psb_c_ctxt cctxt, psb_c_descriptor *cd);
psb_i_t psb_c_cdasb(psb_c_descriptor *cd);
psb_i_t psb_c_cdfree(psb_c_descriptor *cd);
psb_i_t psb_c_cdins(psb_i_t nz, const psb_l_t *ia, const psb_l_t *ja, psb_c_descriptor *cd);
psb_i_t psb_c_cdins_lidx(psb_i_t nz, const psb_l_t *ja, const psb_i_t *lidx, psb_c_descriptor *cd);
bool psb_c_is_owned(psb_l_t gindex, psb_c_descriptor *cd);
bool psb_c_cd_is_asb(psb_c_descriptor *cd);
psb_i_t psb_c_cd_get_local_rows(psb_c_descriptor *cd);
psb_i_t psb_c_cd_get_local_cols(psb_c_descriptor *cd);
psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd);
psb_l_t psb_c_cd_get_global_cols(psb_c_descriptor *cd);
psb_i_t psb_c_cd_get_global_indices(psb_l_t idx[], psb_i_t nidx, bool owned, psb_c_descriptor *cd);
psb_i_t psb_c_g2l(psb_c_descriptor *cdh,psb_l_t gindex,bool cowned);
/* legal values for upd argument */
#define psb_upd_srch_ 98764
#define psb_upd_perm_ 98765
#define psb_upd_def_ psb_upd_srch_
/* legal values for dupl argument */
#define psb_dupl_ovwrt_ 0
#define psb_dupl_add_ 1
#define psb_dupl_err_ 2
#define psb_dupl_def_ psb_dupl_ovwrt_
/* legal values for afmt */
#define PSB_AFMT_CSR "CSR"
#define PSB_AFMT_CSC "CSC"
#define PSB_AFMT_COO "COO"
#define PSB_AFMT_RSB "RSB"
/* Transpose argument */
#define psb_NoTrans_ "N"
#define psb_Trans_ "T"
#define psb_ConjTrans_ "C"
/* legal values for halo swap modes argument */
#define psb_swap_send_ 1
#define psb_swap_recv_ 2
#define psb_swap_sync_ 4
#define psb_swap_mpi_ 8
/* legal values for ovrl update argument */
#define psb_none_ 0
#define psb_sum_ 1
#define psb_avg_ 2
#define psb_square_root_ 3
#define psb_setzero_ 4
#ifdef __cplusplus
}
#endif /* __cplusplus */
#endif

107
cbind/psb_c_cbase.h
Unescape Escape View File

@ -0,0 +1,107 @@
#ifndef PSB_C_CBASE_
#define PSB_C_CBASE_
#include "psb_c_base.h"
#ifdef __cplusplus
extern "C" {
#endif
typedef struct PSB_C_CVECTOR {
void *cvector;
} psb_c_cvector;
typedef struct PSB_C_CSPMAT {
void *cspmat;
} psb_c_cspmat;
/* dense vectors */
psb_c_cvector* psb_c_new_cvector();
psb_i_t psb_c_cvect_get_nrows(psb_c_cvector *xh);
psb_c_t *psb_c_cvect_get_cpy( psb_c_cvector *xh);
psb_i_t psb_c_cvect_f_get_cpy(psb_c_t *v, psb_c_cvector *xh);
psb_i_t psb_c_cvect_zero(psb_c_cvector *xh);
psb_i_t *psb_c_cvect_f_get_pnt(psb_c_cvector *xh);
psb_i_t psb_c_cvect_clone(psb_c_cvector *xh,psb_c_cvector *yh);
psb_i_t psb_c_cgeall(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeall_remote(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeall_remote_options(psb_c_cvector *xh, psb_c_descriptor *cdh,
psb_i_t bldmode, psb_i_t duple);
psb_i_t psb_c_cgeins(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val,
psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val,
psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeasb(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeasb_options(psb_c_cvector *xh, psb_c_descriptor *cdh, psb_i_t dupl);
psb_i_t psb_c_cgefree(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_c_t psb_c_cgetelem(psb_c_cvector *xh,psb_l_t index,psb_c_descriptor *cd);
/* sparse matrices*/
psb_c_cspmat* psb_c_new_cspmat();
psb_i_t psb_c_cspall(psb_c_cspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_cspall_remote(psb_c_cspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_cspasb(psb_c_cspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_cspfree(psb_c_cspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_cspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl,
const psb_c_t *val, psb_c_cspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_cmat_get_nrows(psb_c_cspmat *mh);
psb_i_t psb_c_cmat_get_ncols(psb_c_cspmat *mh);
psb_l_t psb_c_cnnz(psb_c_cspmat *mh,psb_c_descriptor *cdh);
bool psb_c_cis_matupd(psb_c_cspmat *mh,psb_c_descriptor *cdh);
bool psb_c_cis_matasb(psb_c_cspmat *mh,psb_c_descriptor *cdh);
bool psb_c_cis_matbld(psb_c_cspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_cset_matupd(psb_c_cspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_cset_matasb(psb_c_cspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_cset_matbld(psb_c_cspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_ccopy_mat(psb_c_cspmat *ah,psb_c_cspmat *bh,psb_c_descriptor *cdh);
/* psb_i_t psb_c_cspasb_opt(psb_c_cspmat *mh, psb_c_descriptor *cdh, */
/* const char *afmt, psb_i_t upd, psb_i_t dupl); */
psb_i_t psb_c_csprn(psb_c_cspmat *mh, psb_c_descriptor *cdh, _Bool clear);
psb_i_t psb_c_cmat_name_print(psb_c_cspmat *mh, char *name);
psb_i_t psb_c_cvect_set_scal(psb_c_cvector *xh, psb_c_t val);
psb_i_t psb_c_cvect_set_vect(psb_c_cvector *xh, psb_c_t *val, psb_i_t n);
/* psblas computational routines */
psb_c_t psb_c_cgedot(psb_c_cvector *xh, psb_c_cvector *yh, psb_c_descriptor *cdh);
psb_s_t psb_c_cgenrm2(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_cgeamax(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_cgeasum(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_cgenrmi(psb_c_cspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeaxpby(psb_c_t alpha, psb_c_cvector *xh,
psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeaxpbyz(psb_c_t alpha, psb_c_cvector *xh,
psb_c_t beta, psb_c_cvector *yh, psb_c_cvector *zh, psb_c_descriptor *cdh);
psb_i_t psb_c_cspmm(psb_c_t alpha, psb_c_cspmat *ah, psb_c_cvector *xh,
psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_cspmm_opt(psb_c_t alpha, psb_c_cspmat *ah, psb_c_cvector *xh,
psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh,
char *trans, bool doswap);
psb_i_t psb_c_cspsm(psb_c_t alpha, psb_c_cspmat *th, psb_c_cvector *xh,
psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh);
/* Additional computational routines */
psb_i_t psb_c_cgemlt(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_cgemlt2(psb_c_t alpha, psb_c_cvector *xh, psb_c_cvector *yh, psb_c_t beta, psb_c_cvector *zh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgediv(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_cgediv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_cgediv2(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_cgediv2_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *zh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_cgeinv(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_cgeinv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_cgeabs(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *cdh);
psb_i_t psb_c_cgecmp(psb_c_cvector *xh,psb_s_t ch,psb_c_cvector *zh,psb_c_descriptor *cdh);
bool psb_c_cgecmpmat(psb_c_cspmat *ah,psb_c_cspmat *bh,psb_s_t tol,psb_c_descriptor *cdh);
bool psb_c_cgecmpmat_val(psb_c_cspmat *ah,psb_c_t val,psb_s_t tol,psb_c_descriptor *cdh);
psb_i_t psb_c_cgeaddconst(psb_c_cvector *xh,psb_c_t bh,psb_c_cvector *zh,psb_c_descriptor *cdh);
psb_s_t psb_c_cgenrm2_weight(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_descriptor *cdh);
psb_s_t psb_c_cgenrm2_weightmask(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_cvector *idvh,psb_c_descriptor *cdh);
psb_i_t psb_c_cspscal(psb_c_t alpha, psb_c_cspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_cspscalpid(psb_c_t alpha, psb_c_cspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_cspaxpby(psb_c_t alpha, psb_c_cspmat *ah, psb_c_t beta, psb_c_cspmat *bh, psb_c_descriptor *cdh);
#ifdef __cplusplus
}
#endif /* __cplusplus */
#endif

111
cbind/psb_c_dbase.h
Unescape Escape View File

@ -0,0 +1,111 @@
#ifndef PSB_C_DBASE_
#define PSB_C_DBASE_
#include "psb_c_base.h"
#ifdef __cplusplus
extern "C" {
#endif
typedef struct PSB_C_DVECTOR {
void *dvector;
} psb_c_dvector;
typedef struct PSB_C_DSPMAT {
void *dspmat;
} psb_c_dspmat;
/* dense vectors */
psb_c_dvector* psb_c_new_dvector();
psb_i_t psb_c_dvect_get_nrows(psb_c_dvector *xh);
psb_d_t *psb_c_dvect_get_cpy( psb_c_dvector *xh);
psb_i_t psb_c_dvect_f_get_cpy(psb_d_t *v, psb_c_dvector *xh);
psb_i_t psb_c_dvect_zero(psb_c_dvector *xh);
psb_d_t *psb_c_dvect_f_get_pnt( psb_c_dvector *xh);
psb_i_t psb_c_dvect_clone(psb_c_dvector *xh,psb_c_dvector *yh);
psb_i_t psb_c_dgeall(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeall_remote(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeall_remote_options(psb_c_dvector *xh, psb_c_descriptor *cdh,
psb_i_t bldmode, psb_i_t duple);
psb_i_t psb_c_dgeins(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val,
psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val,
psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeasb(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeasb_options(psb_c_dvector *xh, psb_c_descriptor *cdh, psb_i_t dupl);
psb_i_t psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_dgetelem(psb_c_dvector *xh,psb_l_t index,psb_c_descriptor *cd);
/* sparse matrices*/
psb_c_dspmat* psb_c_new_dspmat();
psb_i_t psb_c_dspall(psb_c_dspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_dspall_remote(psb_c_dspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_dspasb(psb_c_dspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_dspfree(psb_c_dspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_dspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl,
const psb_d_t *val, psb_c_dspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_dmat_get_nrows(psb_c_dspmat *mh);
psb_i_t psb_c_dmat_get_ncols(psb_c_dspmat *mh);
psb_l_t psb_c_dnnz(psb_c_dspmat *mh,psb_c_descriptor *cdh);
bool psb_c_dis_matupd(psb_c_dspmat *mh,psb_c_descriptor *cdh);
bool psb_c_dis_matasb(psb_c_dspmat *mh,psb_c_descriptor *cdh);
bool psb_c_dis_matbld(psb_c_dspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_dset_matupd(psb_c_dspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_dset_matasb(psb_c_dspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_dset_matbld(psb_c_dspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_dcopy_mat(psb_c_dspmat *ah,psb_c_dspmat *bh,psb_c_descriptor *cdh);
/* psb_i_t psb_c_dspasb_opt(psb_c_dspmat *mh, psb_c_descriptor *cdh, */
/* const char *afmt, psb_i_t upd, psb_i_t dupl); */
psb_i_t psb_c_dsprn(psb_c_dspmat *mh, psb_c_descriptor *cdh, _Bool clear);
psb_i_t psb_c_dmat_name_print(psb_c_dspmat *mh, char *name);
psb_i_t psb_c_dvect_set_scal(psb_c_dvector *xh, psb_d_t val);
psb_i_t psb_c_dvect_set_vect(psb_c_dvector *xh, psb_d_t *val, psb_i_t n);
/* psblas computational routines */
psb_d_t psb_c_dgedot(psb_c_dvector *xh, psb_c_dvector *yh, psb_c_descriptor *cdh);
psb_d_t psb_c_dgenrm2(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_dgeamax(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_dgeasum(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_dgenrmi(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeaxpby(psb_d_t alpha, psb_c_dvector *xh,
psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeaxpbyz(psb_d_t alpha, psb_c_dvector *xh,
psb_d_t beta, psb_c_dvector *yh, psb_c_dvector *zh, psb_c_descriptor *cdh);
psb_i_t psb_c_dspmm(psb_d_t alpha, psb_c_dspmat *ah, psb_c_dvector *xh,
psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_dspmm_opt(psb_d_t alpha, psb_c_dspmat *ah, psb_c_dvector *xh,
psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh,
char *trans, bool doswap);
psb_i_t psb_c_dspsm(psb_d_t alpha, psb_c_dspmat *th, psb_c_dvector *xh,
psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh);
/* Additional computational routines */
psb_i_t psb_c_dgemlt(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_dgemlt2(psb_d_t alpha, psb_c_dvector *xh, psb_c_dvector *yh, psb_d_t beta, psb_c_dvector *zh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgediv(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_dgediv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_dgediv2(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_dvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_dgediv2_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_dvector *zh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_dgeinv(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_dgeinv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_dgeabs(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_dgecmp(psb_c_dvector *xh,psb_d_t ch,psb_c_dvector *zh,psb_c_descriptor *cdh);
bool psb_c_dgecmpmat(psb_c_dspmat *ah,psb_c_dspmat *bh,psb_d_t tol,psb_c_descriptor *cdh);
bool psb_c_dgecmpmat_val(psb_c_dspmat *ah,psb_d_t val,psb_d_t tol,psb_c_descriptor *cdh);
psb_i_t psb_c_dgeaddconst(psb_c_dvector *xh,psb_d_t bh,psb_c_dvector *zh,psb_c_descriptor *cdh);
psb_d_t psb_c_dgenrm2_weight(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_descriptor *cdh);
psb_d_t psb_c_dgenrm2_weightmask(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_dvector *idvh,psb_c_descriptor *cdh);
psb_i_t psb_c_dmask(psb_c_dvector *ch,psb_c_dvector *xh,psb_c_dvector *mh, bool *t, psb_c_descriptor *cdh);
psb_d_t psb_c_dgemin(psb_c_dvector *xh,psb_c_descriptor *cdh);
psb_d_t psb_c_dminquotient(psb_c_dvector *xh,psb_c_dvector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_dspscal(psb_d_t alpha, psb_c_dspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_dspscalpid(psb_d_t alpha, psb_c_dspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_dspaxpby(psb_d_t alpha, psb_c_dspmat *ah, psb_d_t beta, psb_c_dspmat *bh, psb_c_descriptor *cdh);
#ifdef __cplusplus
}
#endif /* __cplusplus */
#endif

108
cbind/psb_c_sbase.h
Unescape Escape View File

@ -0,0 +1,108 @@
#ifndef PSB_C_SBASE_
#define PSB_C_SBASE_
#include "psb_c_base.h"
#ifdef __cplusplus
extern "C" {
#endif
typedef struct PSB_C_SVECTOR {
void *svector;
} psb_c_svector;
typedef struct PSB_C_SSPMAT {
void *sspmat;
} psb_c_sspmat;
/* dense vectors */
psb_c_svector* psb_c_new_svector();
psb_i_t psb_c_svect_get_nrows(psb_c_svector *xh);
psb_s_t *psb_c_svect_get_cpy( psb_c_svector *xh);
psb_i_t psb_c_svect_f_get_cpy(psb_s_t *v, psb_c_svector *xh);
psb_i_t psb_c_svect_zero(psb_c_svector *xh);
psb_s_t *psb_c_svect_f_get_pnt( psb_c_svector *xh);
psb_i_t psb_c_svect_clone(psb_c_svector *xh,psb_c_svector *yh);
psb_i_t psb_c_sgeall(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeall_remote(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeall_remote_options(psb_c_svector *xh, psb_c_descriptor *cdh,
psb_i_t bldmode, psb_i_t duple);
psb_i_t psb_c_sgeins(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val,
psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val,
psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeasb(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeasb_options(psb_c_svector *xh, psb_c_descriptor *cdh, psb_i_t dupl);
psb_i_t psb_c_sgefree(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_sgetelem(psb_c_svector *xh,psb_l_t index,psb_c_descriptor *cd);
/* sparse matrices*/
psb_c_sspmat* psb_c_new_sspmat();
psb_i_t psb_c_sspall(psb_c_sspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_sspall_remote(psb_c_sspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_sspasb(psb_c_sspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_sspfree(psb_c_sspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_sspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl,
const psb_s_t *val, psb_c_sspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_smat_get_nrows(psb_c_sspmat *mh);
psb_i_t psb_c_smat_get_ncols(psb_c_sspmat *mh);
psb_l_t psb_c_snnz(psb_c_sspmat *mh,psb_c_descriptor *cdh);
bool psb_c_sis_matupd(psb_c_sspmat *mh,psb_c_descriptor *cdh);
bool psb_c_sis_matasb(psb_c_sspmat *mh,psb_c_descriptor *cdh);
bool psb_c_sis_matbld(psb_c_sspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_sset_matupd(psb_c_sspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_sset_matasb(psb_c_sspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_sset_matbld(psb_c_sspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_scopy_mat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_c_descriptor *cdh);
/* psb_i_t psb_c_sspasb_opt(psb_c_sspmat *mh, psb_c_descriptor *cdh, */
/* const char *afmt, psb_i_t upd, psb_i_t dupl); */
psb_i_t psb_c_ssprn(psb_c_sspmat *mh, psb_c_descriptor *cdh, _Bool clear);
psb_i_t psb_c_smat_name_print(psb_c_sspmat *mh, char *name);
psb_i_t psb_c_svect_set_scal(psb_c_svector *xh, psb_s_t val);
psb_i_t psb_c_svect_set_vect(psb_c_svector *xh, psb_s_t *val, psb_i_t n);
/* psblas computational routines */
psb_s_t psb_c_sgedot(psb_c_svector *xh, psb_c_svector *yh, psb_c_descriptor *cdh);
psb_s_t psb_c_sgenrm2(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_sgeamax(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_sgeasum(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_sgenrmi(psb_c_sspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeaxpby(psb_s_t alpha, psb_c_svector *xh,
psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeaxpbyz(psb_s_t alpha, psb_c_svector *xh,
psb_s_t beta, psb_c_svector *yh, psb_c_svector *zh, psb_c_descriptor *cdh);
psb_i_t psb_c_sspmm(psb_s_t alpha, psb_c_sspmat *ah, psb_c_svector *xh,
psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_sspmm_opt(psb_s_t alpha, psb_c_sspmat *ah, psb_c_svector *xh,
psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh,
char *trans, bool doswap);
psb_i_t psb_c_sspsm(psb_s_t alpha, psb_c_sspmat *th, psb_c_svector *xh,
psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh);
/* Additional computational routines */
psb_i_t psb_c_sgemlt(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_sgemlt2(psb_s_t alpha, psb_c_svector *xh, psb_c_svector *yh, psb_s_t beta, psb_c_svector *zh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgediv(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_sgediv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_sgediv2(psb_c_svector *xh,psb_c_svector *yh,psb_c_svector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_sgediv2_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_svector *zh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_sgeinv(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_sgeinv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_sgeabs(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_sgecmp(psb_c_svector *xh,psb_s_t ch,psb_c_svector *zh,psb_c_descriptor *cdh);
bool psb_c_sgecmpmat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_s_t tol,psb_c_descriptor *cdh);
bool psb_c_sgecmpmat_val(psb_c_sspmat *ah,psb_s_t val,psb_s_t tol,psb_c_descriptor *cdh);
psb_i_t psb_c_sgeaddconst(psb_c_svector *xh,psb_s_t bh,psb_c_svector *zh,psb_c_descriptor *cdh);
psb_s_t psb_c_sgenrm2_weight(psb_c_svector *xh,psb_c_svector *wh,psb_c_descriptor *cdh);
psb_s_t psb_c_sgenrm2_weightmask(psb_c_svector *xh,psb_c_svector *wh,psb_c_svector *idvh,psb_c_descriptor *cdh);
psb_i_t psb_c_smask(psb_c_svector *ch,psb_c_svector *xh,psb_c_svector *mh, bool *t, psb_c_descriptor *cdh);
psb_s_t psb_c_sgemin(psb_c_svector *xh,psb_c_descriptor *cdh);
psb_i_t psb_c_sspscal(psb_s_t alpha, psb_c_sspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_sspscalpid(psb_s_t alpha, psb_c_sspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_sspaxpby(psb_s_t alpha, psb_c_sspmat *ah, psb_s_t beta, psb_c_sspmat *bh, psb_c_descriptor *cdh);
#ifdef __cplusplus
}
#endif /* __cplusplus */
#endif

108
cbind/psb_c_zbase.h
Unescape Escape View File

@ -0,0 +1,108 @@
#ifndef PSB_C_ZBASE_
#define PSB_C_ZBASE_
#include "psb_c_base.h"
#ifdef __cplusplus
extern "C" {
#endif
typedef struct PSB_C_ZVECTOR {
void *zvector;
} psb_c_zvector;
typedef struct PSB_C_ZSPMAT {
void *zspmat;
} psb_c_zspmat;
/* dense vectors */
psb_c_zvector* psb_c_new_zvector();
psb_i_t psb_c_zvect_get_nrows(psb_c_zvector *xh);
psb_z_t *psb_c_zvect_get_cpy( psb_c_zvector *xh);
psb_i_t psb_c_zvect_f_get_cpy(psb_z_t *v, psb_c_zvector *xh);
psb_i_t psb_c_zvect_zero(psb_c_zvector *xh);
psb_z_t *psb_c_zvect_f_get_pnt( psb_c_zvector *xh);
psb_i_t psb_c_zvect_clone(psb_c_zvector *xh,psb_c_zvector *yh);
psb_i_t psb_c_zgeall(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeall_remote(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeall_remote_options(psb_c_zvector *xh, psb_c_descriptor *cdh,
psb_i_t bldmode, psb_i_t duple);
psb_i_t psb_c_zgeins(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val,
psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val,
psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeasb(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeasb_options(psb_c_zvector *xh, psb_c_descriptor *cdh, psb_i_t dupl);
psb_i_t psb_c_zgefree(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_z_t psb_c_zgetelem(psb_c_zvector *xh,psb_l_t index,psb_c_descriptor *cd);
/* sparse matrices*/
psb_c_zspmat* psb_c_new_zspmat();
psb_i_t psb_c_zspall(psb_c_zspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_zspall_remote(psb_c_zspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_zspasb(psb_c_zspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_zspfree(psb_c_zspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_zspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl,
const psb_z_t *val, psb_c_zspmat *mh, psb_c_descriptor *cdh);
psb_i_t psb_c_zmat_get_nrows(psb_c_zspmat *mh);
psb_i_t psb_c_zmat_get_ncols(psb_c_zspmat *mh);
psb_l_t psb_c_znnz(psb_c_zspmat *mh,psb_c_descriptor *cdh);
bool psb_c_zis_matupd(psb_c_zspmat *mh,psb_c_descriptor *cdh);
bool psb_c_zis_matasb(psb_c_zspmat *mh,psb_c_descriptor *cdh);
bool psb_c_zis_matbld(psb_c_zspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_zset_matupd(psb_c_zspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_zset_matasb(psb_c_zspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_zset_matbld(psb_c_zspmat *mh,psb_c_descriptor *cdh);
psb_i_t psb_c_zcopy_mat(psb_c_zspmat *ah,psb_c_zspmat *bh,psb_c_descriptor *cdh);
/* psb_i_t psb_c_zspasb_opt(psb_c_zspmat *mh, psb_c_descriptor *cdh, */
/* const char *afmt, psb_i_t upd, psb_i_t dupl); */
psb_i_t psb_c_zsprn(psb_c_zspmat *mh, psb_c_descriptor *cdh, _Bool clear);
psb_i_t psb_c_zmat_name_print(psb_c_zspmat *mh, char *name);
psb_i_t psb_c_zvect_set_scal(psb_c_zvector *xh, psb_z_t val);
psb_i_t psb_c_zvect_set_vect(psb_c_zvector *xh, psb_z_t *val, psb_i_t n);
/* psblas computational routines */
psb_z_t psb_c_zgedot(psb_c_zvector *xh, psb_c_zvector *yh, psb_c_descriptor *cdh);
psb_d_t psb_c_zgenrm2(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_zgeamax(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_zgeasum(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_zgenrmi(psb_c_zspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeaxpby(psb_z_t alpha, psb_c_zvector *xh,
psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeaxpbyz(psb_z_t alpha, psb_c_zvector *xh,
psb_z_t beta, psb_c_zvector *yh, psb_c_zvector *zh, psb_c_descriptor *cdh);
psb_i_t psb_c_zspmm(psb_z_t alpha, psb_c_zspmat *ah, psb_c_zvector *xh,
psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh);
psb_i_t psb_c_zspmm_opt(psb_z_t alpha, psb_c_zspmat *ah, psb_c_zvector *xh,
psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh,
char *trans, bool doswap);
psb_i_t psb_c_zspsm(psb_z_t alpha, psb_c_zspmat *th, psb_c_zvector *xh,
psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh);
/* Additional computational routines */
psb_i_t psb_c_zgemlt(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_zgemlt2(psb_z_t alpha, psb_c_zvector *xh, psb_c_zvector *yh, psb_z_t beta, psb_c_zvector *zh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgediv(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_zgediv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_zgediv2(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_zvector *zh,psb_c_descriptor *cdh);
psb_i_t psb_c_zgediv2_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_zvector *zh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_zgeinv(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_zgeinv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh, bool flag);
psb_i_t psb_c_zgeabs(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh);
psb_i_t psb_c_zgecmp(psb_c_zvector *xh,psb_d_t ch,psb_c_zvector *zh,psb_c_descriptor *cdh);
bool psb_c_zgecmpmat(psb_c_zspmat *ah,psb_c_zspmat *bh,psb_d_t tol,psb_c_descriptor *cdh);
bool psb_c_zgecmpmat_val(psb_c_zspmat *ah,psb_z_t val,psb_d_t tol,psb_c_descriptor *cdh);
psb_i_t psb_c_zgeaddconst(psb_c_zvector *xh,psb_z_t bh,psb_c_zvector *zh,psb_c_descriptor *cdh);
psb_d_t psb_c_zgenrm2_weight(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_descriptor *cdh);
psb_d_t psb_c_zgenrm2_weightmask(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_zvector *idvh,psb_c_descriptor *cdh);
psb_i_t psb_c_zspscal(psb_z_t alpha, psb_c_zspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_zspscalpid(psb_z_t alpha, psb_c_zspmat *ah, psb_c_descriptor *cdh);
psb_i_t psb_c_zspaxpby(psb_z_t alpha, psb_c_zspmat *ah, psb_z_t beta, psb_c_zspmat *bh, psb_c_descriptor *cdh);
#ifdef __cplusplus
}
#endif /* __cplusplus */
#endif

48
cuda/psb_c_cuda_vect_mod.F90
Unescape Escape View File

@ -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()<n) then
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
@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine c_cuda_vect_finalize
subroutine c_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine c_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_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_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,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 +1319,11 @@ contains
end subroutine c_cuda_ins_v
subroutine c_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine c_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_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(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_c_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_c_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine c_cuda_ins_a

48
cuda/psb_d_cuda_vect_mod.F90
Unescape Escape View File

@ -560,12 +560,20 @@ contains
end subroutine d_cuda_sctb_buf
subroutine d_cuda_bld_x(x,this)
subroutine d_cuda_bld_x(x,this,scratch)
use psb_base_mod
real(psb_dpk_), intent(in) :: this(:)
class(psb_d_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 d_cuda_bld_x
subroutine d_cuda_bld_mn(x,n)
subroutine d_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_d_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,'d_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -679,26 +695,34 @@ contains
call x%set_scal(dzero)
end subroutine d_cuda_zero
subroutine d_cuda_asb_m(n, x, info)
subroutine d_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_d_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_d_base_vect_type%asb(n,info)
call x%psb_d_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()<n) then
call x%psb_d_base_vect_type%asb(n,info)
call x%psb_d_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -1252,11 +1276,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 +1309,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 +1319,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 +1332,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

48
cuda/psb_i_cuda_vect_mod.F90
Unescape Escape View File

@ -542,12 +542,20 @@ contains
end subroutine i_cuda_sctb_buf
subroutine i_cuda_bld_x(x,this)
subroutine i_cuda_bld_x(x,this,scratch)
use psb_base_mod
integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_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_
@ -560,11 +568,19 @@ contains
end subroutine i_cuda_bld_x
subroutine i_cuda_bld_mn(x,n)
subroutine i_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_i_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,'i_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -661,26 +677,34 @@ contains
call x%set_scal(izero)
end subroutine i_cuda_zero
subroutine i_cuda_asb_m(n, x, info)
subroutine i_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_i_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_i_base_vect_type%asb(n,info)
call x%psb_i_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()<n) then
call x%psb_i_base_vect_type%asb(n,info)
call x%psb_i_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -814,11 +838,11 @@ contains
call x%free(info)
end subroutine i_cuda_vect_finalize
subroutine i_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine i_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_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) :: val
integer(psb_ipk_), intent(out) :: info
@ -847,7 +871,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
@ -857,11 +881,11 @@ contains
end subroutine i_cuda_ins_v
subroutine i_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine i_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_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) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -870,7 +894,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_i_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_i_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine i_cuda_ins_a

48
cuda/psb_s_cuda_vect_mod.F90
Unescape Escape View File

@ -560,12 +560,20 @@ contains
end subroutine s_cuda_sctb_buf
subroutine s_cuda_bld_x(x,this)
subroutine s_cuda_bld_x(x,this,scratch)
use psb_base_mod
real(psb_spk_), intent(in) :: this(:)
class(psb_s_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 s_cuda_bld_x
subroutine s_cuda_bld_mn(x,n)
subroutine s_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_s_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,'s_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -679,26 +695,34 @@ contains
call x%set_scal(szero)
end subroutine s_cuda_zero
subroutine s_cuda_asb_m(n, x, info)
subroutine s_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_s_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_s_base_vect_type%asb(n,info)
call x%psb_s_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()<n) then
call x%psb_s_base_vect_type%asb(n,info)
call x%psb_s_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine s_cuda_vect_finalize
subroutine s_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine s_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_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_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,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 +1319,11 @@ contains
end subroutine s_cuda_ins_v
subroutine s_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine s_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_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_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_s_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_s_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine s_cuda_ins_a

48
cuda/psb_z_cuda_vect_mod.F90
Unescape Escape View File

@ -560,12 +560,20 @@ contains
end subroutine z_cuda_sctb_buf
subroutine z_cuda_bld_x(x,this)
subroutine z_cuda_bld_x(x,this,scratch)
use psb_base_mod
complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_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 z_cuda_bld_x
subroutine z_cuda_bld_mn(x,n)
subroutine z_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_z_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,'z_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -679,26 +695,34 @@ contains
call x%set_scal(zzero)
end subroutine z_cuda_zero
subroutine z_cuda_asb_m(n, x, info)
subroutine z_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_z_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_z_base_vect_type%asb(n,info)
call x%psb_z_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()<n) then
call x%psb_z_base_vect_type%asb(n,info)
call x%psb_z_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine z_cuda_vect_finalize
subroutine z_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine z_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_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_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,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 +1319,11 @@ contains
end subroutine z_cuda_ins_v
subroutine z_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine z_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_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(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_z_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_z_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine z_cuda_ins_a

47
openacc/psb_c_oacc_vect_mod.F90
Unescape Escape View File

@ -620,11 +620,11 @@ contains
end subroutine inner_gth
end subroutine c_oacc_gthzv_x
subroutine c_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine c_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_c_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_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_c_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 c_oacc_ins_v
subroutine c_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine c_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_c_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(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -684,19 +684,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_c_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_c_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine c_oacc_ins_a
subroutine c_oacc_bld_mn(x, n)
subroutine c_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_oacc), 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%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine c_oacc_bld_mn
subroutine c_oacc_bld_x(x, this)
subroutine c_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
complex(psb_spk_), intent(in) :: this(:)
class(psb_c_vect_oacc), 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%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine c_oacc_bld_x
subroutine c_oacc_asb_m(n, x, info)
subroutine c_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
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()
call x%set_host()
end if
else
if (size(x%v) < n) then
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()
call x%set_host()
end if

47
openacc/psb_d_oacc_vect_mod.F90
Unescape Escape View File

@ -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,19 +684,26 @@ 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_oacc_ins_a
subroutine d_oacc_bld_mn(x, n)
subroutine d_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_oacc), 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%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine d_oacc_bld_mn
subroutine d_oacc_bld_x(x, this)
subroutine d_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
real(psb_dpk_), intent(in) :: this(:)
class(psb_d_vect_oacc), 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%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine d_oacc_bld_x
subroutine d_oacc_asb_m(n, x, info)
subroutine d_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_d_base_vect_type%asb(n, info)
call x%psb_d_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_d_base_vect_type%asb(n, info)
call x%psb_d_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if

47
openacc/psb_i_oacc_vect_mod.F90
Unescape Escape View File

@ -274,11 +274,11 @@ contains
end subroutine inner_gth
end subroutine i_oacc_gthzv_x
subroutine i_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine i_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_i_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) :: val
integer(psb_ipk_), intent(out) :: info
@ -315,7 +315,7 @@ contains
type is (psb_i_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
@ -325,11 +325,11 @@ contains
end subroutine i_oacc_ins_v
subroutine i_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine i_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_i_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) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -338,19 +338,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_i_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_i_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine i_oacc_ins_a
subroutine i_oacc_bld_mn(x, n)
subroutine i_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_oacc), 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%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@ -363,13 +370,21 @@ contains
end subroutine i_oacc_bld_mn
subroutine i_oacc_bld_x(x, this)
subroutine i_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_vect_oacc), 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%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@ -384,27 +399,35 @@ contains
end subroutine i_oacc_bld_x
subroutine i_oacc_asb_m(n, x, info)
subroutine i_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_i_base_vect_type%asb(n, info)
call x%psb_i_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_i_base_vect_type%asb(n, info)
call x%psb_i_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if

47
openacc/psb_l_oacc_vect_mod.F90
Unescape Escape View File

@ -276,11 +276,11 @@ contains
end subroutine inner_gth
end subroutine l_oacc_gthzv_x
subroutine l_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine l_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_l_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_l_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -317,7 +317,7 @@ contains
type is (psb_l_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
@ -327,11 +327,11 @@ contains
end subroutine l_oacc_ins_v
subroutine l_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine l_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_l_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_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -340,19 +340,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_l_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_l_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine l_oacc_ins_a
subroutine l_oacc_bld_mn(x, n)
subroutine l_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_oacc), 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%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@ -365,13 +372,21 @@ contains
end subroutine l_oacc_bld_mn
subroutine l_oacc_bld_x(x, this)
subroutine l_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
integer(psb_lpk_), intent(in) :: this(:)
class(psb_l_vect_oacc), 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%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@ -386,27 +401,35 @@ contains
end subroutine l_oacc_bld_x
subroutine l_oacc_asb_m(n, x, info)
subroutine l_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_l_base_vect_type%asb(n, info)
call x%psb_l_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_l_base_vect_type%asb(n, info)
call x%psb_l_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if

47
openacc/psb_s_oacc_vect_mod.F90
Unescape Escape View File

@ -620,11 +620,11 @@ contains
end subroutine inner_gth
end subroutine s_oacc_gthzv_x
subroutine s_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine s_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_s_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_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_s_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 s_oacc_ins_v
subroutine s_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine s_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_s_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_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -684,19 +684,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_s_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_s_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine s_oacc_ins_a
subroutine s_oacc_bld_mn(x, n)
subroutine s_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_oacc), 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%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine s_oacc_bld_mn
subroutine s_oacc_bld_x(x, this)
subroutine s_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
real(psb_spk_), intent(in) :: this(:)
class(psb_s_vect_oacc), 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%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine s_oacc_bld_x
subroutine s_oacc_asb_m(n, x, info)
subroutine s_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_s_base_vect_type%asb(n, info)
call x%psb_s_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_s_base_vect_type%asb(n, info)
call x%psb_s_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if

47
openacc/psb_z_oacc_vect_mod.F90
Unescape Escape View File

@ -620,11 +620,11 @@ contains
end subroutine inner_gth
end subroutine z_oacc_gthzv_x
subroutine z_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine z_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_z_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_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_z_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 z_oacc_ins_v
subroutine z_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine z_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_z_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(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -684,19 +684,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_z_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_z_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine z_oacc_ins_a
subroutine z_oacc_bld_mn(x, n)
subroutine z_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_oacc), 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%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine z_oacc_bld_mn
subroutine z_oacc_bld_x(x, this)
subroutine z_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_vect_oacc), 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%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine z_oacc_bld_x
subroutine z_oacc_asb_m(n, x, info)
subroutine z_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_z_base_vect_type%asb(n, info)
call x%psb_z_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_z_base_vect_type%asb(n, info)
call x%psb_z_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if

12
test/pdegen/psb_d_pde2d.F90
Unescape Escape View File

@ -406,11 +406,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@ -558,9 +558,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)
@ -570,8 +570,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.'

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

@ -435,11 +435,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz, &
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@ -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.'

12
test/pdegen/psb_s_pde2d.F90
Unescape Escape View File

@ -406,11 +406,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@ -558,9 +558,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)
@ -570,8 +570,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.'

12
test/pdegen/psb_s_pde3d.F90
Unescape Escape View File

@ -435,11 +435,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz, &
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@ -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.'

Write Preview
Loading…
Cancel
Save