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_PATCHLEVEL @PSBLASPATCH@
#define PSB_VERSION_STRING @PSBLASSTRING@ #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@ @CSERIALMPI@
@PSB_IPKDEF@ @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_invalid_ = -1
integer(psb_ipk_), parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 integer(psb_ipk_), parameter :: psb_spmat_null_=0, psb_spmat_bld_=1
integer(psb_ipk_), parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 integer(psb_ipk_), parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4
integer(psb_ipk_), parameter :: psb_matbld_noremote_ = 0
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 integer(psb_ipk_), parameter :: psb_ireg_flgs_=10, psb_ip2_=0
@ -223,9 +226,10 @@ module psb_const_mod
! Duplicate coefficients handling ! Duplicate coefficients handling
! These are usually set while calling spcnv as one of its ! These are usually set while calling spcnv as one of its
! optional arugments. ! optional arugments.
integer(psb_ipk_), parameter :: psb_dupl_add_ = 0 integer(psb_ipk_), parameter :: psb_dupl_null_ = 0
integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 1 integer(psb_ipk_), parameter :: psb_dupl_add_ = 1
integer(psb_ipk_), parameter :: psb_dupl_err_ = 2 integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 2
integer(psb_ipk_), parameter :: psb_dupl_err_ = 3
integer(psb_ipk_), parameter :: psb_dupl_def_ = psb_dupl_add_ integer(psb_ipk_), parameter :: psb_dupl_def_ = psb_dupl_add_
! Matrix update mode ! Matrix update mode
integer(psb_ipk_), parameter :: psb_upd_srch_ = 98764 integer(psb_ipk_), parameter :: psb_upd_srch_ = 98764
@ -329,7 +333,7 @@ module psb_const_mod
contains contains
procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt
end type psb_ctxt_type end type psb_ctxt_type
logical, parameter :: try_newins=.true.
contains contains
function psb_cmp_ctxt(ctxt1, ctxt2) result(res) 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. !! in already existing entries.
!! The transitions among the states are detailed in !! The transitions among the states are detailed in
!! psb_T_mat_mod. !! psb_T_mat_mod.
integer(psb_ipk_), private :: state integer(psb_ipk_), private :: bldstate
!> How to treat duplicate elements when !> How to treat duplicate elements when
!! transitioning from the BUILD to the ASSEMBLED state. !! transitioning from the BUILD to the ASSEMBLED state.
!! While many formats would allow for duplicate !! While many formats would allow for duplicate
@ -137,7 +137,7 @@ module psb_base_mat_mod
!! BUILD state; in our overall design, only COO matrices !! BUILD state; in our overall design, only COO matrices
!! can ever be in the BUILD state, hence all other formats !! can ever be in the BUILD state, hence all other formats
!! cannot have duplicate entries. !! cannot have duplicate entries.
integer(psb_ipk_), private :: duplicate integer(psb_ipk_), private :: duplicate = psb_dupl_null_
!> Is the matrix symmetric? (must also be square) !> Is the matrix symmetric? (must also be square)
logical, private :: symmetric logical, private :: symmetric
!> Is the matrix triangular? (must also be square) !> Is the matrix triangular? (must also be square)
@ -503,7 +503,7 @@ module psb_base_mat_mod
!! in already existing entries. !! in already existing entries.
!! The transitions among the states are detailed in !! The transitions among the states are detailed in
!! psb_T_mat_mod. !! psb_T_mat_mod.
integer(psb_ipk_), private :: state integer(psb_ipk_), private :: bldstate
!> How to treat duplicate elements when !> How to treat duplicate elements when
!! transitioning from the BUILD to the ASSEMBLED state. !! transitioning from the BUILD to the ASSEMBLED state.
!! While many formats would allow for duplicate !! While many formats would allow for duplicate
@ -909,7 +909,7 @@ contains
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = a%state res = a%bldstate
end function psb_base_get_state end function psb_base_get_state
function psb_base_get_nrows(a) result(res) function psb_base_get_nrows(a) result(res)
@ -945,7 +945,7 @@ contains
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
a%state = n a%bldstate = n
end subroutine psb_base_set_state end subroutine psb_base_set_state
@ -960,28 +960,28 @@ contains
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_null_ a%bldstate = psb_spmat_null_
end subroutine psb_base_set_null end subroutine psb_base_set_null
subroutine psb_base_set_bld(a) subroutine psb_base_set_bld(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_bld_ a%bldstate = psb_spmat_bld_
end subroutine psb_base_set_bld end subroutine psb_base_set_bld
subroutine psb_base_set_upd(a) subroutine psb_base_set_upd(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_upd_ a%bldstate = psb_spmat_upd_
end subroutine psb_base_set_upd end subroutine psb_base_set_upd
subroutine psb_base_set_asb(a) subroutine psb_base_set_asb(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_asb_ a%bldstate = psb_spmat_asb_
end subroutine psb_base_set_asb end subroutine psb_base_set_asb
subroutine psb_base_set_sorted(a,val) subroutine psb_base_set_sorted(a,val)
@ -1107,28 +1107,28 @@ contains
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_null_) res = (a%bldstate == psb_spmat_null_)
end function psb_base_is_null end function psb_base_is_null
function psb_base_is_bld(a) result(res) function psb_base_is_bld(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_bld_) res = (a%bldstate == psb_spmat_bld_)
end function psb_base_is_bld end function psb_base_is_bld
function psb_base_is_upd(a) result(res) function psb_base_is_upd(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_upd_) res = (a%bldstate == psb_spmat_upd_)
end function psb_base_is_upd end function psb_base_is_upd
function psb_base_is_asb(a) result(res) function psb_base_is_asb(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_asb_) res = (a%bldstate == psb_spmat_asb_)
end function psb_base_is_asb end function psb_base_is_asb
function psb_base_is_sorted(a) result(res) function psb_base_is_sorted(a) result(res)
@ -1185,7 +1185,7 @@ contains
b%m = a%n b%m = a%n
b%n = a%m b%n = a%m
b%state = a%state b%bldstate = a%bldstate
b%duplicate = a%duplicate b%duplicate = a%duplicate
b%triangle = a%triangle b%triangle = a%triangle
b%symmetric = a%symmetric b%symmetric = a%symmetric
@ -1205,7 +1205,7 @@ contains
b%m = a%n b%m = a%n
b%n = a%m b%n = a%m
b%state = a%state b%bldstate = a%bldstate
b%duplicate = a%duplicate b%duplicate = a%duplicate
b%triangle = a%triangle b%triangle = a%triangle
b%symmetric = a%symmetric b%symmetric = a%symmetric
@ -1225,7 +1225,7 @@ contains
itmp = a%m itmp = a%m
a%m = a%n a%m = a%n
a%n = itmp a%n = itmp
a%state = a%state a%bldstate = a%bldstate
a%duplicate = a%duplicate a%duplicate = a%duplicate
a%triangle = a%triangle a%triangle = a%triangle
a%unitd = a%unitd a%unitd = a%unitd
@ -1402,7 +1402,7 @@ contains
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = a%state res = a%bldstate
end function psb_lbase_get_state end function psb_lbase_get_state
function psb_lbase_get_nrows(a) result(res) function psb_lbase_get_nrows(a) result(res)
@ -1479,7 +1479,7 @@ contains
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
integer(psb_lpk_), intent(in) :: n integer(psb_lpk_), intent(in) :: n
a%state = n a%bldstate = n
end subroutine psb_lbase_set_state end subroutine psb_lbase_set_state
@ -1494,28 +1494,28 @@ contains
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
a%state = psb_spmat_null_ a%bldstate = psb_spmat_null_
end subroutine psb_lbase_set_null end subroutine psb_lbase_set_null
subroutine psb_lbase_set_bld(a) subroutine psb_lbase_set_bld(a)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
a%state = psb_spmat_bld_ a%bldstate = psb_spmat_bld_
end subroutine psb_lbase_set_bld end subroutine psb_lbase_set_bld
subroutine psb_lbase_set_upd(a) subroutine psb_lbase_set_upd(a)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
a%state = psb_spmat_upd_ a%bldstate = psb_spmat_upd_
end subroutine psb_lbase_set_upd end subroutine psb_lbase_set_upd
subroutine psb_lbase_set_asb(a) subroutine psb_lbase_set_asb(a)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(inout) :: a class(psb_lbase_sparse_mat), intent(inout) :: a
a%state = psb_spmat_asb_ a%bldstate = psb_spmat_asb_
end subroutine psb_lbase_set_asb end subroutine psb_lbase_set_asb
subroutine psb_lbase_set_sorted(a,val) subroutine psb_lbase_set_sorted(a,val)
@ -1652,28 +1652,28 @@ contains
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_null_) res = (a%bldstate == psb_spmat_null_)
end function psb_lbase_is_null end function psb_lbase_is_null
function psb_lbase_is_bld(a) result(res) function psb_lbase_is_bld(a) result(res)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_bld_) res = (a%bldstate == psb_spmat_bld_)
end function psb_lbase_is_bld end function psb_lbase_is_bld
function psb_lbase_is_upd(a) result(res) function psb_lbase_is_upd(a) result(res)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_upd_) res = (a%bldstate == psb_spmat_upd_)
end function psb_lbase_is_upd end function psb_lbase_is_upd
function psb_lbase_is_asb(a) result(res) function psb_lbase_is_asb(a) result(res)
implicit none implicit none
class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_asb_) res = (a%bldstate == psb_spmat_asb_)
end function psb_lbase_is_asb end function psb_lbase_is_asb
function psb_lbase_is_sorted(a) result(res) function psb_lbase_is_sorted(a) result(res)
@ -1719,7 +1719,7 @@ contains
b%m = a%n b%m = a%n
b%n = a%m b%n = a%m
b%state = a%state b%bldstate = a%bldstate
b%duplicate = a%duplicate b%duplicate = a%duplicate
b%triangle = a%triangle b%triangle = a%triangle
b%unitd = a%unitd b%unitd = a%unitd
@ -1738,7 +1738,7 @@ contains
b%m = a%n b%m = a%n
b%n = a%m b%n = a%m
b%state = a%state b%bldstate = a%bldstate
b%duplicate = a%duplicate b%duplicate = a%duplicate
b%triangle = a%triangle b%triangle = a%triangle
b%unitd = a%unitd b%unitd = a%unitd
@ -1757,7 +1757,7 @@ contains
itmp = a%m itmp = a%m
a%m = a%n a%m = a%n
a%n = itmp a%n = itmp
a%state = a%state a%bldstate = a%bldstate
a%duplicate = a%duplicate a%duplicate = a%duplicate
a%triangle = a%triangle a%triangle = a%triangle
a%unitd = a%unitd a%unitd = a%unitd
@ -1891,7 +1891,7 @@ contains
lb%m = ib%m lb%m = ib%m
lb%n = ib%n lb%n = ib%n
lb%state = ib%state lb%bldstate = ib%bldstate
lb%duplicate = ib%duplicate lb%duplicate = ib%duplicate
lb%triangle = ib%triangle lb%triangle = ib%triangle
lb%unitd = ib%unitd lb%unitd = ib%unitd
@ -1907,7 +1907,7 @@ contains
ib%m = lb%m ib%m = lb%m
ib%n = lb%n ib%n = lb%n
ib%state = lb%state ib%bldstate = lb%bldstate
ib%duplicate = lb%duplicate ib%duplicate = lb%duplicate
ib%triangle = lb%triangle ib%triangle = lb%triangle
ib%unitd = lb%unitd ib%unitd = lb%unitd

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 :: v(:)
complex(psb_spk_), allocatable :: combuf(:) complex(psb_spk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains contains
! !
! Constructors/allocators ! Constructors/allocators
@ -88,6 +100,22 @@ module psb_c_base_vect_mod
procedure, pass(x) :: asb_e => c_base_asb_e procedure, pass(x) :: asb_e => c_base_asb_e
generic, public :: asb => asb_m, asb_e generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => c_base_free 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. ! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync ! 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 generic, public :: addconst => addconst_a2,addconst_v2
end type psb_c_base_vect_type end type psb_c_base_vect_type
public :: psb_c_base_vect public :: psb_c_base_vect
@ -263,14 +289,22 @@ contains
!! \brief Build method from an array !! \brief Build method from an array
!! \param x(:) input array to be copied !! \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 use psb_realloc_mod
implicit none implicit none
complex(psb_spk_), intent(in) :: this(:) complex(psb_spk_), intent(in) :: this(:)
class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -295,15 +329,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine c_base_bld_mn
@ -312,15 +354,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine c_base_bld_en
@ -340,9 +390,29 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine c_base_all 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: !> Function base_mold:
!! \memberof psb_c_base_vect_type !! \memberof psb_c_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type !! \brief Mold method: return a variable with the same dynamic type
@ -388,55 +458,116 @@ contains
!! \param info return code !! \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 use psi_serial_mod
implicit none implicit none
class(psb_c_base_vect_type), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0 info = 0
if (psb_errstatus_fatal()) return if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then if (try_newins) then
info = psb_err_invalid_vect_state_ if (x%is_bld()) then
else if (n > min(size(irl),size(val))) then ncfs_ = x%get_ncfs()
info = psb_err_invalid_input_ isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
else call psb_ensure_size(isz,x%iv,info)
isz = size(x%v) k = ncfs_
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n do i = 1, n
!loop over all val's rows !loop over all val's rows
! row actual block row ! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me k = k + 1
! 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 ! this row belongs to me
! copy i-th row of block val in x ! 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 end if
enddo 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 else
info = 321 isz = size(x%v)
! !$ call psb_errpush(info,name) select case(dupl)
! !$ goto 9999 case(psb_dupl_ovwrt_)
end select 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 end if
call x%set_host() call x%set_host()
if (info /= 0) then if (info /= 0) then
@ -446,11 +577,11 @@ contains
end subroutine c_base_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_c_base_vect_type), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_c_base_vect_type), intent(inout) :: val class(psb_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -463,7 +594,7 @@ contains
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine c_base_asb_m 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine c_base_asb_e end subroutine c_base_asb_e
@ -572,9 +809,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info) 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%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(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 & if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free') & psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine c_base_free end subroutine c_base_free
@ -637,7 +875,104 @@ contains
if (allocated(x%comid)) & if (allocated(x%comid)) &
& deallocate(x%comid,stat=info) & deallocate(x%comid,stat=info)
end subroutine c_base_free_comid 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 ! The base version of SYNC & friends does nothing, it's just
@ -733,6 +1068,24 @@ contains
res = .true. res = .true.
end function c_base_is_sync 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. ! 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) :: get_fmt => c_vect_get_fmt
procedure, pass(x) :: is_remote_build => c_vect_is_remote_build 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) :: 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) :: get_nrmv => c_vect_get_nrmv
procedure, pass(x) :: set_nrmv => c_vect_set_nrmv procedure, pass(x) :: set_nrmv => c_vect_set_nrmv
procedure, pass(x) :: all => c_vect_all procedure, pass(x) :: all => c_vect_all
procedure, pass(x) :: reall => c_vect_reall procedure, pass(x) :: reall => c_vect_reall
procedure, pass(x) :: zero => c_vect_zero procedure, pass(x) :: zero => c_vect_zero
procedure, pass(x) :: asb => c_vect_asb 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) :: gthab => c_vect_gthab
procedure, pass(x) :: gthzv => c_vect_gthzv procedure, pass(x) :: gthzv => c_vect_gthzv
generic, public :: gth => gthab, gthzv generic, public :: gth => gthab, gthzv
@ -187,7 +201,11 @@ contains
implicit none implicit none
class(psb_c_vect_type), intent(in) :: x class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = x%dupl if (allocated(x%v)) then
res = x%v%get_dupl()
else
res = psb_dupl_null_
end if
end function c_vect_get_dupl end function c_vect_get_dupl
subroutine c_vect_set_dupl(x,val) subroutine c_vect_set_dupl(x,val)
@ -195,13 +213,117 @@ contains
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then if (allocated(x%v)) then
x%dupl = val if (present(val)) then
else call x%v%set_dupl(val)
x%dupl = psb_dupl_def_ else
call x%v%set_dupl(psb_dupl_def_)
end if
end if end if
end subroutine c_vect_set_dupl 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) function c_vect_get_nrmv(x) result(res)
implicit none implicit none
class(psb_c_vect_type), intent(in) :: x class(psb_c_vect_type), intent(in) :: x
@ -216,7 +338,6 @@ contains
x%nrmv = val x%nrmv = val
end subroutine c_vect_set_nrmv end subroutine c_vect_set_nrmv
function c_vect_is_remote_build(x) result(res) function c_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -287,16 +408,25 @@ contains
info = psb_success_ info = psb_success_
call y%free(info) call y%free(info)
if ((info==0).and.allocated(x%v)) then 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 if
end subroutine c_vect_clone 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(:) complex(psb_spk_), intent(in) :: invect(:)
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -307,17 +437,25 @@ contains
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif 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 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 integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld class(psb_c_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
@ -328,17 +466,25 @@ contains
else else
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif 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 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 integer(psb_epk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -348,7 +494,7 @@ contains
else else
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif 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 end subroutine c_vect_bld_en
@ -450,8 +596,19 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
call x%set_bld()
end subroutine c_vect_all 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) subroutine c_vect_reall(n, x, info)
implicit none implicit none
@ -476,16 +633,18 @@ contains
end subroutine c_vect_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then 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 if
end subroutine c_vect_asb end subroutine c_vect_asb
@ -540,11 +699,11 @@ contains
end subroutine c_vect_free 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 use psi_serial_mod
implicit none implicit none
class(psb_c_vect_type), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -557,15 +716,15 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine c_vect_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_c_vect_type), intent(inout) :: x 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_i_vect_type), intent(inout) :: irl
class(psb_c_vect_type), intent(inout) :: val class(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -578,7 +737,7 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine c_vect_ins_v end subroutine c_vect_ins_v
@ -600,6 +759,7 @@ contains
if (allocated(x%v%v)) then if (allocated(x%v%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info) call x%v%free(info)
endif endif
end if 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 :: v(:)
real(psb_dpk_), allocatable :: combuf(:) real(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains contains
! !
! Constructors/allocators ! Constructors/allocators
@ -88,6 +100,22 @@ module psb_d_base_vect_mod
procedure, pass(x) :: asb_e => d_base_asb_e procedure, pass(x) :: asb_e => d_base_asb_e
generic, public :: asb => asb_m, asb_e generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => d_base_free procedure, pass(x) :: free => d_base_free
procedure, pass(x) :: reinit => d_base_reinit
procedure, pass(x) :: set_ncfs => d_base_set_ncfs
procedure, pass(x) :: get_ncfs => d_base_get_ncfs
procedure, pass(x) :: set_dupl => d_base_set_dupl
procedure, pass(x) :: get_dupl => d_base_get_dupl
procedure, pass(x) :: set_state => d_base_set_state
procedure, pass(x) :: set_null => d_base_set_null
procedure, pass(x) :: set_bld => d_base_set_bld
procedure, pass(x) :: set_upd => d_base_set_upd
procedure, pass(x) :: set_asb => d_base_set_asb
procedure, pass(x) :: get_state => d_base_get_state
procedure, pass(x) :: is_null => d_base_is_null
procedure, pass(x) :: is_bld => d_base_is_bld
procedure, pass(x) :: is_upd => d_base_is_upd
procedure, pass(x) :: is_asb => d_base_is_asb
procedure, pass(x) :: base_cpy => d_base_cpy
! !
! Sync: centerpiece of handling of external storage. ! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync ! Any derived class having extra storage upon sync
@ -218,8 +246,6 @@ module psb_d_base_vect_mod
procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2 procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2
generic, public :: minquotient => minquotient_v, minquotient_a2 generic, public :: minquotient => minquotient_v, minquotient_a2
end type psb_d_base_vect_type end type psb_d_base_vect_type
public :: psb_d_base_vect public :: psb_d_base_vect
@ -270,14 +296,22 @@ contains
!! \brief Build method from an array !! \brief Build method from an array
!! \param x(:) input array to be copied !! \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 use psb_realloc_mod
implicit none implicit none
real(psb_dpk_), intent(in) :: this(:) real(psb_dpk_), intent(in) :: this(:)
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -302,15 +336,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine d_base_bld_mn
@ -319,15 +361,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine d_base_bld_en
@ -347,9 +397,29 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine d_base_all end subroutine d_base_all
subroutine d_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = dzero
call x%set_host()
call x%set_upd()
end if
end subroutine d_base_reinit
!> Function base_mold: !> Function base_mold:
!! \memberof psb_d_base_vect_type !! \memberof psb_d_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type !! \brief Mold method: return a variable with the same dynamic type
@ -395,55 +465,116 @@ contains
!! \param info return code !! \param info return code
!! !!
! !
subroutine d_base_ins_a(n,irl,val,dupl,x,info) subroutine d_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0 info = 0
if (psb_errstatus_fatal()) return if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then if (try_newins) then
info = psb_err_invalid_vect_state_ if (x%is_bld()) then
else if (n > min(size(irl),size(val))) then ncfs_ = x%get_ncfs()
info = psb_err_invalid_input_ isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
else call psb_ensure_size(isz,x%iv,info)
isz = size(x%v) k = ncfs_
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n do i = 1, n
!loop over all val's rows !loop over all val's rows
! row actual block row ! 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 ! this row belongs to me
! copy i-th row of block val in x ! copy i-th row of block val in x
x%v(irl(i)) = val(i) x%v(k) = val(i)
end if x%iv(k) = irl(i)
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 end if
enddo 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 else
info = 321 isz = size(x%v)
! !$ call psb_errpush(info,name) select case(dupl)
! !$ goto 9999 case(psb_dupl_ovwrt_)
end select 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 end if
call x%set_host() call x%set_host()
if (info /= 0) then if (info /= 0) then
@ -453,11 +584,11 @@ contains
end subroutine d_base_ins_a end subroutine d_base_ins_a
subroutine d_base_ins_v(n,irl,val,dupl,x,info) subroutine d_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -470,7 +601,7 @@ contains
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_dpk_), allocatable :: vv(:)
info = 0 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine d_base_asb_m 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_dpk_), allocatable :: vv(:)
info = 0 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine d_base_asb_e end subroutine d_base_asb_e
@ -579,9 +816,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info) 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%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(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 & if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free') & psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine d_base_free end subroutine d_base_free
@ -644,7 +882,104 @@ contains
if (allocated(x%comid)) & if (allocated(x%comid)) &
& deallocate(x%comid,stat=info) & deallocate(x%comid,stat=info)
end subroutine d_base_free_comid end subroutine d_base_free_comid
function d_base_get_ncfs(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function d_base_get_ncfs
function d_base_get_dupl(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function d_base_get_dupl
function d_base_get_state(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function d_base_get_state
function d_base_is_null(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function d_base_is_null
function d_base_is_bld(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function d_base_is_bld
function d_base_is_upd(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function d_base_is_upd
function d_base_is_asb(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function d_base_is_asb
subroutine d_base_set_ncfs(n,x)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine d_base_set_ncfs
subroutine d_base_set_dupl(n,x)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine d_base_set_dupl
subroutine d_base_set_state(n,x)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine d_base_set_state
subroutine d_base_set_null(x)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine d_base_set_null
subroutine d_base_set_bld(x)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine d_base_set_bld
subroutine d_base_set_upd(x)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine d_base_set_upd
subroutine d_base_set_asb(x)
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine d_base_set_asb
! !
! The base version of SYNC & friends does nothing, it's just ! The base version of SYNC & friends does nothing, it's just
@ -740,6 +1075,24 @@ contains
res = .true. res = .true.
end function d_base_is_sync 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. ! 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) :: get_fmt => d_vect_get_fmt
procedure, pass(x) :: is_remote_build => d_vect_is_remote_build procedure, pass(x) :: is_remote_build => d_vect_is_remote_build
procedure, pass(x) :: set_remote_build => d_vect_set_remote_build procedure, pass(x) :: set_remote_build => d_vect_set_remote_build
procedure, pass(x) :: get_dupl => d_vect_get_dupl
procedure, pass(x) :: set_dupl => d_vect_set_dupl
procedure, pass(x) :: get_nrmv => d_vect_get_nrmv procedure, pass(x) :: get_nrmv => d_vect_get_nrmv
procedure, pass(x) :: set_nrmv => d_vect_set_nrmv procedure, pass(x) :: set_nrmv => d_vect_set_nrmv
procedure, pass(x) :: all => d_vect_all procedure, pass(x) :: all => d_vect_all
procedure, pass(x) :: reall => d_vect_reall procedure, pass(x) :: reall => d_vect_reall
procedure, pass(x) :: zero => d_vect_zero procedure, pass(x) :: zero => d_vect_zero
procedure, pass(x) :: asb => d_vect_asb procedure, pass(x) :: asb => d_vect_asb
procedure, pass(x) :: set_dupl => d_vect_set_dupl
procedure, pass(x) :: get_dupl => d_vect_get_dupl
procedure, pass(x) :: set_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) :: gthab => d_vect_gthab
procedure, pass(x) :: gthzv => d_vect_gthzv procedure, pass(x) :: gthzv => d_vect_gthzv
generic, public :: gth => gthab, gthzv generic, public :: gth => gthab, gthzv
@ -194,7 +208,11 @@ contains
implicit none implicit none
class(psb_d_vect_type), intent(in) :: x class(psb_d_vect_type), intent(in) :: x
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = x%dupl if (allocated(x%v)) then
res = x%v%get_dupl()
else
res = psb_dupl_null_
end if
end function d_vect_get_dupl end function d_vect_get_dupl
subroutine d_vect_set_dupl(x,val) subroutine d_vect_set_dupl(x,val)
@ -202,13 +220,117 @@ contains
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then if (allocated(x%v)) then
x%dupl = val if (present(val)) then
else call x%v%set_dupl(val)
x%dupl = psb_dupl_def_ else
call x%v%set_dupl(psb_dupl_def_)
end if
end if end if
end subroutine d_vect_set_dupl end subroutine d_vect_set_dupl
function d_vect_get_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) function d_vect_get_nrmv(x) result(res)
implicit none implicit none
class(psb_d_vect_type), intent(in) :: x class(psb_d_vect_type), intent(in) :: x
@ -223,7 +345,6 @@ contains
x%nrmv = val x%nrmv = val
end subroutine d_vect_set_nrmv end subroutine d_vect_set_nrmv
function d_vect_is_remote_build(x) result(res) function d_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -294,16 +415,25 @@ contains
info = psb_success_ info = psb_success_
call y%free(info) call y%free(info)
if ((info==0).and.allocated(x%v)) then 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 if
end subroutine d_vect_clone 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(:) real(psb_dpk_), intent(in) :: invect(:)
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -314,17 +444,25 @@ contains
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif 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 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 integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld class(psb_d_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
@ -335,17 +473,25 @@ contains
else else
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif 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 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 integer(psb_epk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -355,7 +501,7 @@ contains
else else
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif 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 end subroutine d_vect_bld_en
@ -457,8 +603,19 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
call x%set_bld()
end subroutine d_vect_all end subroutine d_vect_all
subroutine d_vect_reinit(x, info)
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine d_vect_reinit
subroutine d_vect_reall(n, x, info) subroutine d_vect_reall(n, x, info)
implicit none implicit none
@ -483,16 +640,18 @@ contains
end subroutine d_vect_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then 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 if
end subroutine d_vect_asb end subroutine d_vect_asb
@ -547,11 +706,11 @@ contains
end subroutine d_vect_free end subroutine d_vect_free
subroutine d_vect_ins_a(n,irl,val,x,info) subroutine d_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -564,15 +723,15 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine d_vect_ins_a end subroutine d_vect_ins_a
subroutine d_vect_ins_v(n,irl,val,x,info) subroutine d_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: irl
class(psb_d_vect_type), intent(inout) :: val class(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -585,7 +744,7 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine d_vect_ins_v end subroutine d_vect_ins_v
@ -607,6 +766,7 @@ contains
if (allocated(x%v%v)) then if (allocated(x%v%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info) call x%v%free(info)
endif endif
end if 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 :: v(:)
integer(psb_ipk_), allocatable :: combuf(:) integer(psb_ipk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains contains
! !
! Constructors/allocators ! Constructors/allocators
@ -86,6 +98,22 @@ module psb_i_base_vect_mod
procedure, pass(x) :: asb_e => i_base_asb_e procedure, pass(x) :: asb_e => i_base_asb_e
generic, public :: asb => asb_m, asb_e generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => i_base_free 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. ! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync ! 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 end type psb_i_base_vect_type
public :: psb_i_base_vect public :: psb_i_base_vect
@ -196,14 +222,22 @@ contains
!! \brief Build method from an array !! \brief Build method from an array
!! \param x(:) input array to be copied !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: this(:) integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_base_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -228,15 +262,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine i_base_bld_mn
@ -245,15 +287,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine i_base_bld_en
@ -273,9 +323,29 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine i_base_all 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: !> Function base_mold:
!! \memberof psb_i_base_vect_type !! \memberof psb_i_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type !! \brief Mold method: return a variable with the same dynamic type
@ -321,55 +391,116 @@ contains
!! \param info return code !! \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 use psi_serial_mod
implicit none implicit none
class(psb_i_base_vect_type), intent(inout) :: x 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) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0 info = 0
if (psb_errstatus_fatal()) return if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then if (try_newins) then
info = psb_err_invalid_vect_state_ if (x%is_bld()) then
else if (n > min(size(irl),size(val))) then ncfs_ = x%get_ncfs()
info = psb_err_invalid_input_ isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
else call psb_ensure_size(isz,x%iv,info)
isz = size(x%v) k = ncfs_
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n do i = 1, n
!loop over all val's rows !loop over all val's rows
! row actual block row ! 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 ! this row belongs to me
! copy i-th row of block val in x ! 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 end if
enddo enddo
call x%set_ncfs(k)
case(psb_dupl_add_) else if (x%is_upd()) then
dupl_ = x%get_dupl()
do i = 1, n if (.not.allocated(x%v)) then
!loop over all val's rows info = psb_err_invalid_vect_state_
if ((1 <= irl(i)).and.(irl(i) <= isz)) then else if (n > min(size(irl),size(val))) then
! this row belongs to me info = psb_err_invalid_input_
! copy i-th row of block val in x else
x%v(irl(i)) = x%v(irl(i)) + val(i) isz = size(x%v)
end if select case(dupl_)
enddo case(psb_dupl_ovwrt_)
do i = 1, n
case default !loop over all val's rows
info = 321 ! row actual block row
! !$ call psb_errpush(info,name) if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! !$ goto 9999 ! this row belongs to me
end select ! 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 end if
call x%set_host() call x%set_host()
if (info /= 0) then if (info /= 0) then
@ -379,11 +510,11 @@ contains
end subroutine i_base_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_i_base_vect_type), intent(inout) :: x 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) :: irl
class(psb_i_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -396,7 +527,7 @@ contains
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine i_base_asb_m 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine i_base_asb_e end subroutine i_base_asb_e
@ -505,9 +742,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info) 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%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(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 & if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free') & psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine i_base_free end subroutine i_base_free
@ -570,7 +808,104 @@ contains
if (allocated(x%comid)) & if (allocated(x%comid)) &
& deallocate(x%comid,stat=info) & deallocate(x%comid,stat=info)
end subroutine i_base_free_comid 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 ! The base version of SYNC & friends does nothing, it's just
@ -666,6 +1001,24 @@ contains
res = .true. res = .true.
end function i_base_is_sync 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. ! 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) :: get_fmt => i_vect_get_fmt
procedure, pass(x) :: is_remote_build => i_vect_is_remote_build 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) :: 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) :: get_nrmv => i_vect_get_nrmv
procedure, pass(x) :: set_nrmv => i_vect_set_nrmv procedure, pass(x) :: set_nrmv => i_vect_set_nrmv
procedure, pass(x) :: all => i_vect_all procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: reall => i_vect_reall procedure, pass(x) :: reall => i_vect_reall
procedure, pass(x) :: zero => i_vect_zero procedure, pass(x) :: zero => i_vect_zero
procedure, pass(x) :: asb => i_vect_asb 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) :: gthab => i_vect_gthab
procedure, pass(x) :: gthzv => i_vect_gthzv procedure, pass(x) :: gthzv => i_vect_gthzv
generic, public :: gth => gthab, gthzv generic, public :: gth => gthab, gthzv
@ -132,7 +146,11 @@ contains
implicit none implicit none
class(psb_i_vect_type), intent(in) :: x class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = x%dupl if (allocated(x%v)) then
res = x%v%get_dupl()
else
res = psb_dupl_null_
end if
end function i_vect_get_dupl end function i_vect_get_dupl
subroutine i_vect_set_dupl(x,val) subroutine i_vect_set_dupl(x,val)
@ -140,13 +158,117 @@ contains
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then if (allocated(x%v)) then
x%dupl = val if (present(val)) then
else call x%v%set_dupl(val)
x%dupl = psb_dupl_def_ else
call x%v%set_dupl(psb_dupl_def_)
end if
end if end if
end subroutine i_vect_set_dupl 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) function i_vect_get_nrmv(x) result(res)
implicit none implicit none
class(psb_i_vect_type), intent(in) :: x class(psb_i_vect_type), intent(in) :: x
@ -161,7 +283,6 @@ contains
x%nrmv = val x%nrmv = val
end subroutine i_vect_set_nrmv end subroutine i_vect_set_nrmv
function i_vect_is_remote_build(x) result(res) function i_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -232,16 +353,25 @@ contains
info = psb_success_ info = psb_success_
call y%free(info) call y%free(info)
if ((info==0).and.allocated(x%v)) then 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 if
end subroutine i_vect_clone 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(:) integer(psb_ipk_), intent(in) :: invect(:)
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -252,17 +382,25 @@ contains
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif 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 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 integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld class(psb_i_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
@ -273,17 +411,25 @@ contains
else else
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif 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 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 integer(psb_epk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -293,7 +439,7 @@ contains
else else
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif 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 end subroutine i_vect_bld_en
@ -395,8 +541,19 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
call x%set_bld()
end subroutine i_vect_all 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) subroutine i_vect_reall(n, x, info)
implicit none implicit none
@ -421,16 +578,18 @@ contains
end subroutine i_vect_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then 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 if
end subroutine i_vect_asb end subroutine i_vect_asb
@ -485,11 +644,11 @@ contains
end subroutine i_vect_free 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 use psi_serial_mod
implicit none implicit none
class(psb_i_vect_type), intent(inout) :: x 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) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -502,15 +661,15 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine i_vect_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_i_vect_type), intent(inout) :: x 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) :: irl
class(psb_i_vect_type), intent(inout) :: val class(psb_i_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -523,7 +682,7 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine i_vect_ins_v end subroutine i_vect_ins_v
@ -545,6 +704,7 @@ contains
if (allocated(x%v%v)) then if (allocated(x%v%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info) call x%v%free(info)
endif endif
end if 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 :: v(:)
integer(psb_lpk_), allocatable :: combuf(:) integer(psb_lpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains contains
! !
! Constructors/allocators ! Constructors/allocators
@ -87,6 +99,22 @@ module psb_l_base_vect_mod
procedure, pass(x) :: asb_e => l_base_asb_e procedure, pass(x) :: asb_e => l_base_asb_e
generic, public :: asb => asb_m, asb_e generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => l_base_free 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. ! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync ! 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 end type psb_l_base_vect_type
public :: psb_l_base_vect public :: psb_l_base_vect
@ -197,14 +223,22 @@ contains
!! \brief Build method from an array !! \brief Build method from an array
!! \param x(:) input array to be copied !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_lpk_), intent(in) :: this(:) integer(psb_lpk_), intent(in) :: this(:)
class(psb_l_base_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -229,15 +263,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine l_base_bld_mn
@ -246,15 +288,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine l_base_bld_en
@ -274,9 +324,29 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine l_base_all 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: !> Function base_mold:
!! \memberof psb_l_base_vect_type !! \memberof psb_l_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type !! \brief Mold method: return a variable with the same dynamic type
@ -322,55 +392,116 @@ contains
!! \param info return code !! \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 use psi_serial_mod
implicit none implicit none
class(psb_l_base_vect_type), intent(inout) :: x 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_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0 info = 0
if (psb_errstatus_fatal()) return if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then if (try_newins) then
info = psb_err_invalid_vect_state_ if (x%is_bld()) then
else if (n > min(size(irl),size(val))) then ncfs_ = x%get_ncfs()
info = psb_err_invalid_input_ isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
else call psb_ensure_size(isz,x%iv,info)
isz = size(x%v) k = ncfs_
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n do i = 1, n
!loop over all val's rows !loop over all val's rows
! row actual block row ! 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 ! this row belongs to me
! copy i-th row of block val in x ! 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 end if
enddo enddo
call x%set_ncfs(k)
case(psb_dupl_add_) else if (x%is_upd()) then
dupl_ = x%get_dupl()
do i = 1, n if (.not.allocated(x%v)) then
!loop over all val's rows info = psb_err_invalid_vect_state_
if ((1 <= irl(i)).and.(irl(i) <= isz)) then else if (n > min(size(irl),size(val))) then
! this row belongs to me info = psb_err_invalid_input_
! copy i-th row of block val in x else
x%v(irl(i)) = x%v(irl(i)) + val(i) isz = size(x%v)
end if select case(dupl_)
enddo case(psb_dupl_ovwrt_)
do i = 1, n
case default !loop over all val's rows
info = 321 ! row actual block row
! !$ call psb_errpush(info,name) if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! !$ goto 9999 ! this row belongs to me
end select ! 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 end if
call x%set_host() call x%set_host()
if (info /= 0) then if (info /= 0) then
@ -380,11 +511,11 @@ contains
end subroutine l_base_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_l_base_vect_type), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_l_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -397,7 +528,7 @@ contains
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine l_base_asb_m 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine l_base_asb_e end subroutine l_base_asb_e
@ -506,9 +743,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info) 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%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(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 & if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free') & psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine l_base_free end subroutine l_base_free
@ -571,7 +809,104 @@ contains
if (allocated(x%comid)) & if (allocated(x%comid)) &
& deallocate(x%comid,stat=info) & deallocate(x%comid,stat=info)
end subroutine l_base_free_comid 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 ! The base version of SYNC & friends does nothing, it's just
@ -667,6 +1002,24 @@ contains
res = .true. res = .true.
end function l_base_is_sync 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. ! 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) :: get_fmt => l_vect_get_fmt
procedure, pass(x) :: is_remote_build => l_vect_is_remote_build 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) :: 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) :: get_nrmv => l_vect_get_nrmv
procedure, pass(x) :: set_nrmv => l_vect_set_nrmv procedure, pass(x) :: set_nrmv => l_vect_set_nrmv
procedure, pass(x) :: all => l_vect_all procedure, pass(x) :: all => l_vect_all
procedure, pass(x) :: reall => l_vect_reall procedure, pass(x) :: reall => l_vect_reall
procedure, pass(x) :: zero => l_vect_zero procedure, pass(x) :: zero => l_vect_zero
procedure, pass(x) :: asb => l_vect_asb 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) :: gthab => l_vect_gthab
procedure, pass(x) :: gthzv => l_vect_gthzv procedure, pass(x) :: gthzv => l_vect_gthzv
generic, public :: gth => gthab, gthzv generic, public :: gth => gthab, gthzv
@ -133,7 +147,11 @@ contains
implicit none implicit none
class(psb_l_vect_type), intent(in) :: x class(psb_l_vect_type), intent(in) :: x
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = x%dupl if (allocated(x%v)) then
res = x%v%get_dupl()
else
res = psb_dupl_null_
end if
end function l_vect_get_dupl end function l_vect_get_dupl
subroutine l_vect_set_dupl(x,val) subroutine l_vect_set_dupl(x,val)
@ -141,13 +159,117 @@ contains
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then if (allocated(x%v)) then
x%dupl = val if (present(val)) then
else call x%v%set_dupl(val)
x%dupl = psb_dupl_def_ else
call x%v%set_dupl(psb_dupl_def_)
end if
end if end if
end subroutine l_vect_set_dupl 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) function l_vect_get_nrmv(x) result(res)
implicit none implicit none
class(psb_l_vect_type), intent(in) :: x class(psb_l_vect_type), intent(in) :: x
@ -162,7 +284,6 @@ contains
x%nrmv = val x%nrmv = val
end subroutine l_vect_set_nrmv end subroutine l_vect_set_nrmv
function l_vect_is_remote_build(x) result(res) function l_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -233,16 +354,25 @@ contains
info = psb_success_ info = psb_success_
call y%free(info) call y%free(info)
if ((info==0).and.allocated(x%v)) then 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 if
end subroutine l_vect_clone 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(:) integer(psb_lpk_), intent(in) :: invect(:)
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -253,17 +383,25 @@ contains
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif 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 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 integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld class(psb_l_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
@ -274,17 +412,25 @@ contains
else else
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif 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 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 integer(psb_epk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -294,7 +440,7 @@ contains
else else
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif 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 end subroutine l_vect_bld_en
@ -396,8 +542,19 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
call x%set_bld()
end subroutine l_vect_all 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) subroutine l_vect_reall(n, x, info)
implicit none implicit none
@ -422,16 +579,18 @@ contains
end subroutine l_vect_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then 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 if
end subroutine l_vect_asb end subroutine l_vect_asb
@ -486,11 +645,11 @@ contains
end subroutine l_vect_free 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 use psi_serial_mod
implicit none implicit none
class(psb_l_vect_type), intent(inout) :: x 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_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -503,15 +662,15 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine l_vect_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_l_vect_type), intent(inout) :: x 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_i_vect_type), intent(inout) :: irl
class(psb_l_vect_type), intent(inout) :: val class(psb_l_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -524,7 +683,7 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine l_vect_ins_v end subroutine l_vect_ins_v
@ -546,6 +705,7 @@ contains
if (allocated(x%v%v)) then if (allocated(x%v%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info) call x%v%free(info)
endif endif
end if 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 :: v(:)
real(psb_spk_), allocatable :: combuf(:) real(psb_spk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains contains
! !
! Constructors/allocators ! Constructors/allocators
@ -88,6 +100,22 @@ module psb_s_base_vect_mod
procedure, pass(x) :: asb_e => s_base_asb_e procedure, pass(x) :: asb_e => s_base_asb_e
generic, public :: asb => asb_m, asb_e generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => s_base_free 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. ! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync ! 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 procedure, pass(x) :: minquotient_a2 => s_base_minquotient_a2
generic, public :: minquotient => minquotient_v, minquotient_a2 generic, public :: minquotient => minquotient_v, minquotient_a2
end type psb_s_base_vect_type end type psb_s_base_vect_type
public :: psb_s_base_vect public :: psb_s_base_vect
@ -270,14 +296,22 @@ contains
!! \brief Build method from an array !! \brief Build method from an array
!! \param x(:) input array to be copied !! \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 use psb_realloc_mod
implicit none implicit none
real(psb_spk_), intent(in) :: this(:) real(psb_spk_), intent(in) :: this(:)
class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -302,15 +336,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine s_base_bld_mn
@ -319,15 +361,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine s_base_bld_en
@ -347,9 +397,29 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine s_base_all 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: !> Function base_mold:
!! \memberof psb_s_base_vect_type !! \memberof psb_s_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type !! \brief Mold method: return a variable with the same dynamic type
@ -395,55 +465,116 @@ contains
!! \param info return code !! \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 use psi_serial_mod
implicit none implicit none
class(psb_s_base_vect_type), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0 info = 0
if (psb_errstatus_fatal()) return if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then if (try_newins) then
info = psb_err_invalid_vect_state_ if (x%is_bld()) then
else if (n > min(size(irl),size(val))) then ncfs_ = x%get_ncfs()
info = psb_err_invalid_input_ isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
else call psb_ensure_size(isz,x%iv,info)
isz = size(x%v) k = ncfs_
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n do i = 1, n
!loop over all val's rows !loop over all val's rows
! row actual block row ! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me k = k + 1
! 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 ! this row belongs to me
! copy i-th row of block val in x ! 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 end if
enddo 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 else
info = 321 isz = size(x%v)
! !$ call psb_errpush(info,name) select case(dupl)
! !$ goto 9999 case(psb_dupl_ovwrt_)
end select 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 end if
call x%set_host() call x%set_host()
if (info /= 0) then if (info /= 0) then
@ -453,11 +584,11 @@ contains
end subroutine s_base_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_s_base_vect_type), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_s_base_vect_type), intent(inout) :: val class(psb_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -470,7 +601,7 @@ contains
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine s_base_asb_m 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine s_base_asb_e end subroutine s_base_asb_e
@ -579,9 +816,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info) 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%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(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 & if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free') & psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine s_base_free end subroutine s_base_free
@ -644,7 +882,104 @@ contains
if (allocated(x%comid)) & if (allocated(x%comid)) &
& deallocate(x%comid,stat=info) & deallocate(x%comid,stat=info)
end subroutine s_base_free_comid 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 ! The base version of SYNC & friends does nothing, it's just
@ -740,6 +1075,24 @@ contains
res = .true. res = .true.
end function s_base_is_sync 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. ! 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) :: get_fmt => s_vect_get_fmt
procedure, pass(x) :: is_remote_build => s_vect_is_remote_build 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) :: 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) :: get_nrmv => s_vect_get_nrmv
procedure, pass(x) :: set_nrmv => s_vect_set_nrmv procedure, pass(x) :: set_nrmv => s_vect_set_nrmv
procedure, pass(x) :: all => s_vect_all procedure, pass(x) :: all => s_vect_all
procedure, pass(x) :: reall => s_vect_reall procedure, pass(x) :: reall => s_vect_reall
procedure, pass(x) :: zero => s_vect_zero procedure, pass(x) :: zero => s_vect_zero
procedure, pass(x) :: asb => s_vect_asb 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) :: gthab => s_vect_gthab
procedure, pass(x) :: gthzv => s_vect_gthzv procedure, pass(x) :: gthzv => s_vect_gthzv
generic, public :: gth => gthab, gthzv generic, public :: gth => gthab, gthzv
@ -194,7 +208,11 @@ contains
implicit none implicit none
class(psb_s_vect_type), intent(in) :: x class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = x%dupl if (allocated(x%v)) then
res = x%v%get_dupl()
else
res = psb_dupl_null_
end if
end function s_vect_get_dupl end function s_vect_get_dupl
subroutine s_vect_set_dupl(x,val) subroutine s_vect_set_dupl(x,val)
@ -202,13 +220,117 @@ contains
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then if (allocated(x%v)) then
x%dupl = val if (present(val)) then
else call x%v%set_dupl(val)
x%dupl = psb_dupl_def_ else
call x%v%set_dupl(psb_dupl_def_)
end if
end if end if
end subroutine s_vect_set_dupl 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) function s_vect_get_nrmv(x) result(res)
implicit none implicit none
class(psb_s_vect_type), intent(in) :: x class(psb_s_vect_type), intent(in) :: x
@ -223,7 +345,6 @@ contains
x%nrmv = val x%nrmv = val
end subroutine s_vect_set_nrmv end subroutine s_vect_set_nrmv
function s_vect_is_remote_build(x) result(res) function s_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -294,16 +415,25 @@ contains
info = psb_success_ info = psb_success_
call y%free(info) call y%free(info)
if ((info==0).and.allocated(x%v)) then 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 if
end subroutine s_vect_clone 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(:) real(psb_spk_), intent(in) :: invect(:)
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -314,17 +444,25 @@ contains
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif 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 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 integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld class(psb_s_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
@ -335,17 +473,25 @@ contains
else else
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif 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 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 integer(psb_epk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -355,7 +501,7 @@ contains
else else
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif 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 end subroutine s_vect_bld_en
@ -457,8 +603,19 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
call x%set_bld()
end subroutine s_vect_all 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) subroutine s_vect_reall(n, x, info)
implicit none implicit none
@ -483,16 +640,18 @@ contains
end subroutine s_vect_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then 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 if
end subroutine s_vect_asb end subroutine s_vect_asb
@ -547,11 +706,11 @@ contains
end subroutine s_vect_free 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 use psi_serial_mod
implicit none implicit none
class(psb_s_vect_type), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -564,15 +723,15 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine s_vect_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_s_vect_type), intent(inout) :: x 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_i_vect_type), intent(inout) :: irl
class(psb_s_vect_type), intent(inout) :: val class(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -585,7 +744,7 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine s_vect_ins_v end subroutine s_vect_ins_v
@ -607,6 +766,7 @@ contains
if (allocated(x%v%v)) then if (allocated(x%v%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info) call x%v%free(info)
endif endif
end if 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 :: v(:)
complex(psb_dpk_), allocatable :: combuf(:) complex(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:) integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains contains
! !
! Constructors/allocators ! Constructors/allocators
@ -88,6 +100,22 @@ module psb_z_base_vect_mod
procedure, pass(x) :: asb_e => z_base_asb_e procedure, pass(x) :: asb_e => z_base_asb_e
generic, public :: asb => asb_m, asb_e generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => z_base_free 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. ! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync ! 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 generic, public :: addconst => addconst_a2,addconst_v2
end type psb_z_base_vect_type end type psb_z_base_vect_type
public :: psb_z_base_vect public :: psb_z_base_vect
@ -263,14 +289,22 @@ contains
!! \brief Build method from an array !! \brief Build method from an array
!! \param x(:) input array to be copied !! \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 use psb_realloc_mod
implicit none implicit none
complex(psb_dpk_), intent(in) :: this(:) complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -295,15 +329,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine z_base_bld_mn
@ -312,15 +354,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \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 use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) 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 end subroutine z_base_bld_en
@ -340,9 +390,29 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine z_base_all 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: !> Function base_mold:
!! \memberof psb_z_base_vect_type !! \memberof psb_z_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type !! \brief Mold method: return a variable with the same dynamic type
@ -388,55 +458,116 @@ contains
!! \param info return code !! \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 use psi_serial_mod
implicit none implicit none
class(psb_z_base_vect_type), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0 info = 0
if (psb_errstatus_fatal()) return if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then if (try_newins) then
info = psb_err_invalid_vect_state_ if (x%is_bld()) then
else if (n > min(size(irl),size(val))) then ncfs_ = x%get_ncfs()
info = psb_err_invalid_input_ isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
else call psb_ensure_size(isz,x%iv,info)
isz = size(x%v) k = ncfs_
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n do i = 1, n
!loop over all val's rows !loop over all val's rows
! row actual block row ! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me k = k + 1
! 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 ! this row belongs to me
! copy i-th row of block val in x ! 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 end if
enddo 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 else
info = 321 isz = size(x%v)
! !$ call psb_errpush(info,name) select case(dupl)
! !$ goto 9999 case(psb_dupl_ovwrt_)
end select 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 end if
call x%set_host() call x%set_host()
if (info /= 0) then if (info /= 0) then
@ -446,11 +577,11 @@ contains
end subroutine z_base_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_z_base_vect_type), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_z_base_vect_type), intent(inout) :: val class(psb_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -463,7 +594,7 @@ contains
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine z_base_asb_m 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info 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 info = 0
if (x%get_nrows() < n) & if (present(scratch)) then
& call psb_realloc(n,x%v,info) scratch_ = scratch
if (info /= 0) & else
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') 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() call x%sync()
end subroutine z_base_asb_e end subroutine z_base_asb_e
@ -572,9 +809,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info) 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%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(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 & if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free') & psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine z_base_free end subroutine z_base_free
@ -637,7 +875,104 @@ contains
if (allocated(x%comid)) & if (allocated(x%comid)) &
& deallocate(x%comid,stat=info) & deallocate(x%comid,stat=info)
end subroutine z_base_free_comid 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 ! The base version of SYNC & friends does nothing, it's just
@ -733,6 +1068,24 @@ contains
res = .true. res = .true.
end function z_base_is_sync 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. ! 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) :: get_fmt => z_vect_get_fmt
procedure, pass(x) :: is_remote_build => z_vect_is_remote_build 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) :: 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) :: get_nrmv => z_vect_get_nrmv
procedure, pass(x) :: set_nrmv => z_vect_set_nrmv procedure, pass(x) :: set_nrmv => z_vect_set_nrmv
procedure, pass(x) :: all => z_vect_all procedure, pass(x) :: all => z_vect_all
procedure, pass(x) :: reall => z_vect_reall procedure, pass(x) :: reall => z_vect_reall
procedure, pass(x) :: zero => z_vect_zero procedure, pass(x) :: zero => z_vect_zero
procedure, pass(x) :: asb => z_vect_asb 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) :: gthab => z_vect_gthab
procedure, pass(x) :: gthzv => z_vect_gthzv procedure, pass(x) :: gthzv => z_vect_gthzv
generic, public :: gth => gthab, gthzv generic, public :: gth => gthab, gthzv
@ -187,7 +201,11 @@ contains
implicit none implicit none
class(psb_z_vect_type), intent(in) :: x class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_) :: res integer(psb_ipk_) :: res
res = x%dupl if (allocated(x%v)) then
res = x%v%get_dupl()
else
res = psb_dupl_null_
end if
end function z_vect_get_dupl end function z_vect_get_dupl
subroutine z_vect_set_dupl(x,val) subroutine z_vect_set_dupl(x,val)
@ -195,13 +213,117 @@ contains
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then if (allocated(x%v)) then
x%dupl = val if (present(val)) then
else call x%v%set_dupl(val)
x%dupl = psb_dupl_def_ else
call x%v%set_dupl(psb_dupl_def_)
end if
end if end if
end subroutine z_vect_set_dupl 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) function z_vect_get_nrmv(x) result(res)
implicit none implicit none
class(psb_z_vect_type), intent(in) :: x class(psb_z_vect_type), intent(in) :: x
@ -216,7 +338,6 @@ contains
x%nrmv = val x%nrmv = val
end subroutine z_vect_set_nrmv end subroutine z_vect_set_nrmv
function z_vect_is_remote_build(x) result(res) function z_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -287,16 +408,25 @@ contains
info = psb_success_ info = psb_success_
call y%free(info) call y%free(info)
if ((info==0).and.allocated(x%v)) then 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 if
end subroutine z_vect_clone 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(:) complex(psb_dpk_), intent(in) :: invect(:)
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -307,17 +437,25 @@ contains
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif 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 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 integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld class(psb_z_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
@ -328,17 +466,25 @@ contains
else else
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif 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 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 integer(psb_epk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -348,7 +494,7 @@ contains
else else
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif 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 end subroutine z_vect_bld_en
@ -450,8 +596,19 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
call x%set_bld()
end subroutine z_vect_all 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) subroutine z_vect_reall(n, x, info)
implicit none implicit none
@ -476,16 +633,18 @@ contains
end subroutine z_vect_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then 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 if
end subroutine z_vect_asb end subroutine z_vect_asb
@ -540,11 +699,11 @@ contains
end subroutine z_vect_free 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 use psi_serial_mod
implicit none implicit none
class(psb_z_vect_type), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -557,15 +716,15 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine z_vect_ins_a 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 use psi_serial_mod
implicit none implicit none
class(psb_z_vect_type), intent(inout) :: x 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_i_vect_type), intent(inout) :: irl
class(psb_z_vect_type), intent(inout) :: val class(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -578,7 +737,7 @@ contains
return return
end if end if
dupl = x%get_dupl() dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine z_vect_ins_v end subroutine z_vect_ins_v
@ -600,6 +759,7 @@ contains
if (allocated(x%v%v)) then if (allocated(x%v%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%base_cpy(tmp)
call x%v%free(info) call x%v%free(info)
endif endif
end if 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 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 import
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -78,6 +78,7 @@ Module psb_c_tools_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_casb_vect end subroutine psb_casb_vect
subroutine psb_casb_vect_r2(x, desc_a, info,mold, scratch) subroutine psb_casb_vect_r2(x, desc_a, info,mold, scratch)
import import
@ -250,13 +251,14 @@ Module psb_c_tools_mod
end interface end interface
interface psb_spasb 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 import
implicit none implicit none
type(psb_cspmat_type), intent (inout) :: a type(psb_cspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt character(len=*), optional, intent(in) :: afmt
class(psb_c_base_sparse_mat), intent(in), optional :: mold class(psb_c_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and 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 interface psb_geasb
subroutine psb_dasb_vect(x, desc_a, info,mold, scratch) subroutine psb_dasb_vect(x, desc_a, info,mold, scratch,dupl)
import import
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -78,6 +78,7 @@ Module psb_d_tools_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dasb_vect end subroutine psb_dasb_vect
subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch) subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch)
import import
@ -250,13 +251,14 @@ Module psb_d_tools_mod
end interface end interface
interface psb_spasb interface psb_spasb
subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and) subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
import import
implicit none implicit none
type(psb_dspmat_type), intent (inout) :: a type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and logical, intent(in), optional :: bld_and

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 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 import
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -77,6 +77,7 @@ Module psb_i_tools_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_iasb_vect end subroutine psb_iasb_vect
subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch) subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch)
import 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 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 import
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -77,6 +77,7 @@ Module psb_l_tools_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_lasb_vect end subroutine psb_lasb_vect
subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch) subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch)
import 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 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 import
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -78,6 +78,7 @@ Module psb_s_tools_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_sasb_vect end subroutine psb_sasb_vect
subroutine psb_sasb_vect_r2(x, desc_a, info,mold, scratch) subroutine psb_sasb_vect_r2(x, desc_a, info,mold, scratch)
import import
@ -250,13 +251,14 @@ Module psb_s_tools_mod
end interface end interface
interface psb_spasb 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 import
implicit none implicit none
type(psb_sspmat_type), intent (inout) :: a type(psb_sspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold class(psb_s_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and 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 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 import
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -78,6 +78,7 @@ Module psb_z_tools_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_zasb_vect end subroutine psb_zasb_vect
subroutine psb_zasb_vect_r2(x, desc_a, info,mold, scratch) subroutine psb_zasb_vect_r2(x, desc_a, info,mold, scratch)
import import
@ -250,13 +251,14 @@ Module psb_z_tools_mod
end interface end interface
interface psb_spasb 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 import
implicit none implicit none
type(psb_zspmat_type), intent (inout) :: a type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt character(len=*), optional, intent(in) :: afmt
class(psb_z_base_sparse_mat), intent(in), optional :: mold class(psb_z_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and 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 goto 9999
endif endif
allocate(psb_c_base_vect_type :: x%v, stat=info) call x%all(nr,info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') 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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents. ! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false. ! default: .false.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_casb_vect
implicit none implicit none
@ -60,6 +60,7 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables ! local variables
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -80,10 +81,9 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
scratch_ = .false. scratch_ = .false.
if (present(scratch)) scratch_ = scratch if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np) call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
@ -100,39 +100,83 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then dupl_ = x%get_dupl()
call x%free(info) if (try_newins) then
call x%bld(ncol,mold=mold) 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 else
if (x%is_remote_build()) then if (scratch_) then
block call x%free(info)
integer(psb_lpk_), allocatable :: lvx(:) call x%bld(ncol,mold=mold)
complex(psb_spk_), allocatable :: vx(:) else
integer(psb_ipk_), allocatable :: ivx(:) if (x%is_bld().and.present(dupl)) then
integer(psb_ipk_) :: nrmv, nx, i dupl_ = dupl
end if
nrmv = x%get_nrmv() if (x%is_remote_build()) then
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) block
nx = size(vx) integer(psb_lpk_), allocatable :: lvx(:)
call psb_realloc(nx,ivx,info) complex(psb_spk_), allocatable :: vx(:)
call desc_a%g2l(lvx,ivx,info,owned=.true.) integer(psb_ipk_), allocatable :: ivx(:)
call x%ins(nx,ivx,vx,info) integer(psb_ipk_) :: nrmv, nx, i
end block
end if nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
call x%asb(ncol,info) nx = size(vx)
! ..update halo elements.. call psb_realloc(nx,ivx,info)
call psb_halo(x,desc_a,info) call desc_a%g2l(lvx,ivx,info,owned=.true.)
if(info /= psb_success_) then call x%ins(nx,ivx,vx,nrow,info)
info=psb_err_from_subroutine_ end block
call psb_errpush(info,name,a_err='psb_halo') end if
goto 9999
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 end if
call x%cnv(mold) if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -202,7 +246,7 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
else else
do i=1, n do i=1, n
dupl_ = x(i)%get_dupl() dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info) call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit if (info /= 0) exit
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x(i),desc_a,info) 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 logical, intent(in), optional :: local
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_ integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,info) call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -198,7 +198,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local logical, intent(in), optional :: local
!locals..... !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 integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me 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.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,info) call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -368,7 +368,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then

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

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory) ! 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_base_mod, psb_protect_name => psb_cspasb
use psb_sort_mod use psb_sort_mod
use psi_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 character(len=*), optional, intent(in) :: afmt
class(psb_c_base_sparse_mat), intent(in), optional :: mold class(psb_c_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
!....Locals.... !....Locals....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act integer(psb_ipk_) :: np,me, err_act
@ -103,7 +104,12 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
!check on errors encountered in psdspins !check on errors encountered in psdspins
if (a%is_bld()) then if (a%is_bld()) then
dupl_ = a%get_dupl() if (present(dupl)) then
dupl_ = dupl
else
dupl_ = a%get_dupl()
end if
! !
! First case: we come from a fresh build. ! First case: we come from a fresh build.
! !
@ -180,7 +186,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
if (bld_and_) then if (bld_and_) then
!!$ allocate(a%ad,mold=a%a) !!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o !!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info) !!$ call a%split_nd(n_row,n_col,info)
!!$ block !!$ block
!!$ character(len=1024) :: fname !!$ character(len=1024) :: fname
!!$ type(psb_c_coo_sparse_mat) :: acoo !!$ 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 goto 9999
endif endif
allocate(psb_d_base_vect_type :: x%v, stat=info) call x%all(nr,info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') 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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents. ! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false. ! default: .false.
! !
subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) subroutine psb_dasb_vect(x, desc_a, info, mold, scratch, dupl)
use psb_base_mod, psb_protect_name => psb_dasb_vect use psb_base_mod, psb_protect_name => psb_dasb_vect
implicit none implicit none
@ -60,6 +60,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables ! local variables
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -80,10 +81,9 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
scratch_ = .false. scratch_ = .false.
if (present(scratch)) scratch_ = scratch if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np) call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
@ -100,39 +100,83 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then dupl_ = x%get_dupl()
call x%free(info) if (try_newins) then
call x%bld(ncol,mold=mold) 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 else
if (x%is_remote_build()) then if (scratch_) then
block call x%free(info)
integer(psb_lpk_), allocatable :: lvx(:) call x%bld(ncol,mold=mold)
real(psb_dpk_), allocatable :: vx(:) else
integer(psb_ipk_), allocatable :: ivx(:) if (x%is_bld().and.present(dupl)) then
integer(psb_ipk_) :: nrmv, nx, i dupl_ = dupl
end if
nrmv = x%get_nrmv() if (x%is_remote_build()) then
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) block
nx = size(vx) integer(psb_lpk_), allocatable :: lvx(:)
call psb_realloc(nx,ivx,info) real(psb_dpk_), allocatable :: vx(:)
call desc_a%g2l(lvx,ivx,info,owned=.true.) integer(psb_ipk_), allocatable :: ivx(:)
call x%ins(nx,ivx,vx,info) integer(psb_ipk_) :: nrmv, nx, i
end block
end if nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
call x%asb(ncol,info) nx = size(vx)
! ..update halo elements.. call psb_realloc(nx,ivx,info)
call psb_halo(x,desc_a,info) call desc_a%g2l(lvx,ivx,info,owned=.true.)
if(info /= psb_success_) then call x%ins(nx,ivx,vx,nrow,info)
info=psb_err_from_subroutine_ end block
call psb_errpush(info,name,a_err='psb_halo') end if
goto 9999
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 end if
call x%cnv(mold) if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -202,7 +246,7 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
else else
do i=1, n do i=1, n
dupl_ = x(i)%get_dupl() dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info) call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit if (info /= 0) exit
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x(i),desc_a,info) 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 logical, intent(in), optional :: local
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_ integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,info) call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -198,7 +198,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local logical, intent(in), optional :: local
!locals..... !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 integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me 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.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,info) call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -368,7 +368,7 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then

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

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory) ! psb_upd_perm_ Permutation(more memory)
! !
! !
subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and) subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
use psb_base_mod, psb_protect_name => psb_dspasb use psb_base_mod, psb_protect_name => psb_dspasb
use psb_sort_mod use psb_sort_mod
use psi_mod use psi_mod
@ -59,6 +59,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and)
character(len=*), optional, intent(in) :: afmt character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
!....Locals.... !....Locals....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act integer(psb_ipk_) :: np,me, err_act
@ -103,7 +104,12 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and)
!check on errors encountered in psdspins !check on errors encountered in psdspins
if (a%is_bld()) then if (a%is_bld()) then
dupl_ = a%get_dupl() if (present(dupl)) then
dupl_ = dupl
else
dupl_ = a%get_dupl()
end if
! !
! First case: we come from a fresh build. ! First case: we come from a fresh build.
! !
@ -180,7 +186,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and)
if (bld_and_) then if (bld_and_) then
!!$ allocate(a%ad,mold=a%a) !!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o !!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info) !!$ call a%split_nd(n_row,n_col,info)
!!$ block !!$ block
!!$ character(len=1024) :: fname !!$ character(len=1024) :: fname
!!$ type(psb_d_coo_sparse_mat) :: acoo !!$ type(psb_d_coo_sparse_mat) :: acoo

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 goto 9999
endif endif
allocate(psb_i_base_vect_type :: x%v, stat=info) call x%all(nr,info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') 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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents. ! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false. ! default: .false.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_iasb_vect
implicit none implicit none
@ -60,6 +60,7 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables ! local variables
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -80,10 +81,9 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
scratch_ = .false. scratch_ = .false.
if (present(scratch)) scratch_ = scratch if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np) call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
@ -100,39 +100,83 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then dupl_ = x%get_dupl()
call x%free(info) if (try_newins) then
call x%bld(ncol,mold=mold) 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 else
if (x%is_remote_build()) then if (scratch_) then
block call x%free(info)
integer(psb_lpk_), allocatable :: lvx(:) call x%bld(ncol,mold=mold)
integer(psb_ipk_), allocatable :: vx(:) else
integer(psb_ipk_), allocatable :: ivx(:) if (x%is_bld().and.present(dupl)) then
integer(psb_ipk_) :: nrmv, nx, i dupl_ = dupl
end if
nrmv = x%get_nrmv() if (x%is_remote_build()) then
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) block
nx = size(vx) integer(psb_lpk_), allocatable :: lvx(:)
call psb_realloc(nx,ivx,info) integer(psb_ipk_), allocatable :: vx(:)
call desc_a%g2l(lvx,ivx,info,owned=.true.) integer(psb_ipk_), allocatable :: ivx(:)
call x%ins(nx,ivx,vx,info) integer(psb_ipk_) :: nrmv, nx, i
end block
end if nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
call x%asb(ncol,info) nx = size(vx)
! ..update halo elements.. call psb_realloc(nx,ivx,info)
call psb_halo(x,desc_a,info) call desc_a%g2l(lvx,ivx,info,owned=.true.)
if(info /= psb_success_) then call x%ins(nx,ivx,vx,nrow,info)
info=psb_err_from_subroutine_ end block
call psb_errpush(info,name,a_err='psb_halo') end if
goto 9999
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 end if
call x%cnv(mold) if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -202,7 +246,7 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch)
else else
do i=1, n do i=1, n
dupl_ = x(i)%get_dupl() dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info) call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit if (info /= 0) exit
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x(i),desc_a,info) 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 logical, intent(in), optional :: local
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_ integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,info) call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -198,7 +198,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local logical, intent(in), optional :: local
!locals..... !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 integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me 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.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,info) call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -368,7 +368,7 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then

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 goto 9999
endif endif
allocate(psb_l_base_vect_type :: x%v, stat=info) call x%all(nr,info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') 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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents. ! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false. ! default: .false.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_lasb_vect
implicit none implicit none
@ -60,6 +60,7 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables ! local variables
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -80,10 +81,9 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
scratch_ = .false. scratch_ = .false.
if (present(scratch)) scratch_ = scratch if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np) call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
@ -100,39 +100,83 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then dupl_ = x%get_dupl()
call x%free(info) if (try_newins) then
call x%bld(ncol,mold=mold) 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 else
if (x%is_remote_build()) then if (scratch_) then
block call x%free(info)
integer(psb_lpk_), allocatable :: lvx(:) call x%bld(ncol,mold=mold)
integer(psb_lpk_), allocatable :: vx(:) else
integer(psb_ipk_), allocatable :: ivx(:) if (x%is_bld().and.present(dupl)) then
integer(psb_ipk_) :: nrmv, nx, i dupl_ = dupl
end if
nrmv = x%get_nrmv() if (x%is_remote_build()) then
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) block
nx = size(vx) integer(psb_lpk_), allocatable :: lvx(:)
call psb_realloc(nx,ivx,info) integer(psb_lpk_), allocatable :: vx(:)
call desc_a%g2l(lvx,ivx,info,owned=.true.) integer(psb_ipk_), allocatable :: ivx(:)
call x%ins(nx,ivx,vx,info) integer(psb_ipk_) :: nrmv, nx, i
end block
end if nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
call x%asb(ncol,info) nx = size(vx)
! ..update halo elements.. call psb_realloc(nx,ivx,info)
call psb_halo(x,desc_a,info) call desc_a%g2l(lvx,ivx,info,owned=.true.)
if(info /= psb_success_) then call x%ins(nx,ivx,vx,nrow,info)
info=psb_err_from_subroutine_ end block
call psb_errpush(info,name,a_err='psb_halo') end if
goto 9999
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 end if
call x%cnv(mold) if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -202,7 +246,7 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch)
else else
do i=1, n do i=1, n
dupl_ = x(i)%get_dupl() dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info) call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit if (info /= 0) exit
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x(i),desc_a,info) 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 logical, intent(in), optional :: local
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_ integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,info) call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -198,7 +198,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local logical, intent(in), optional :: local
!locals..... !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 integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me 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.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,info) call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -368,7 +368,7 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then

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 goto 9999
endif endif
allocate(psb_s_base_vect_type :: x%v, stat=info) call x%all(nr,info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') 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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents. ! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false. ! default: .false.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_sasb_vect
implicit none implicit none
@ -60,6 +60,7 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables ! local variables
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -80,10 +81,9 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
scratch_ = .false. scratch_ = .false.
if (present(scratch)) scratch_ = scratch if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np) call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
@ -100,39 +100,83 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then dupl_ = x%get_dupl()
call x%free(info) if (try_newins) then
call x%bld(ncol,mold=mold) 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 else
if (x%is_remote_build()) then if (scratch_) then
block call x%free(info)
integer(psb_lpk_), allocatable :: lvx(:) call x%bld(ncol,mold=mold)
real(psb_spk_), allocatable :: vx(:) else
integer(psb_ipk_), allocatable :: ivx(:) if (x%is_bld().and.present(dupl)) then
integer(psb_ipk_) :: nrmv, nx, i dupl_ = dupl
end if
nrmv = x%get_nrmv() if (x%is_remote_build()) then
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) block
nx = size(vx) integer(psb_lpk_), allocatable :: lvx(:)
call psb_realloc(nx,ivx,info) real(psb_spk_), allocatable :: vx(:)
call desc_a%g2l(lvx,ivx,info,owned=.true.) integer(psb_ipk_), allocatable :: ivx(:)
call x%ins(nx,ivx,vx,info) integer(psb_ipk_) :: nrmv, nx, i
end block
end if nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
call x%asb(ncol,info) nx = size(vx)
! ..update halo elements.. call psb_realloc(nx,ivx,info)
call psb_halo(x,desc_a,info) call desc_a%g2l(lvx,ivx,info,owned=.true.)
if(info /= psb_success_) then call x%ins(nx,ivx,vx,nrow,info)
info=psb_err_from_subroutine_ end block
call psb_errpush(info,name,a_err='psb_halo') end if
goto 9999
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 end if
call x%cnv(mold) if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -202,7 +246,7 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch)
else else
do i=1, n do i=1, n
dupl_ = x(i)%get_dupl() dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info) call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit if (info /= 0) exit
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x(i),desc_a,info) 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 logical, intent(in), optional :: local
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_ integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,info) call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -198,7 +198,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local logical, intent(in), optional :: local
!locals..... !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 integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me 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.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,info) call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -368,7 +368,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then

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

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory) ! 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_base_mod, psb_protect_name => psb_sspasb
use psb_sort_mod use psb_sort_mod
use psi_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 character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold class(psb_s_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
!....Locals.... !....Locals....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act integer(psb_ipk_) :: np,me, err_act
@ -103,7 +104,12 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
!check on errors encountered in psdspins !check on errors encountered in psdspins
if (a%is_bld()) then if (a%is_bld()) then
dupl_ = a%get_dupl() if (present(dupl)) then
dupl_ = dupl
else
dupl_ = a%get_dupl()
end if
! !
! First case: we come from a fresh build. ! First case: we come from a fresh build.
! !
@ -180,7 +186,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
if (bld_and_) then if (bld_and_) then
!!$ allocate(a%ad,mold=a%a) !!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o !!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info) !!$ call a%split_nd(n_row,n_col,info)
!!$ block !!$ block
!!$ character(len=1024) :: fname !!$ character(len=1024) :: fname
!!$ type(psb_s_coo_sparse_mat) :: acoo !!$ 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 goto 9999
endif endif
allocate(psb_z_base_vect_type :: x%v, stat=info) call x%all(nr,info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') 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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents. ! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false. ! default: .false.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_zasb_vect
implicit none implicit none
@ -60,6 +60,7 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables ! local variables
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -80,10 +81,9 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
scratch_ = .false. scratch_ = .false.
if (present(scratch)) scratch_ = scratch if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np) call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
@ -100,39 +100,83 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then dupl_ = x%get_dupl()
call x%free(info) if (try_newins) then
call x%bld(ncol,mold=mold) 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 else
if (x%is_remote_build()) then if (scratch_) then
block call x%free(info)
integer(psb_lpk_), allocatable :: lvx(:) call x%bld(ncol,mold=mold)
complex(psb_dpk_), allocatable :: vx(:) else
integer(psb_ipk_), allocatable :: ivx(:) if (x%is_bld().and.present(dupl)) then
integer(psb_ipk_) :: nrmv, nx, i dupl_ = dupl
end if
nrmv = x%get_nrmv() if (x%is_remote_build()) then
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info) block
nx = size(vx) integer(psb_lpk_), allocatable :: lvx(:)
call psb_realloc(nx,ivx,info) complex(psb_dpk_), allocatable :: vx(:)
call desc_a%g2l(lvx,ivx,info,owned=.true.) integer(psb_ipk_), allocatable :: ivx(:)
call x%ins(nx,ivx,vx,info) integer(psb_ipk_) :: nrmv, nx, i
end block
end if nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
call x%asb(ncol,info) nx = size(vx)
! ..update halo elements.. call psb_realloc(nx,ivx,info)
call psb_halo(x,desc_a,info) call desc_a%g2l(lvx,ivx,info,owned=.true.)
if(info /= psb_success_) then call x%ins(nx,ivx,vx,nrow,info)
info=psb_err_from_subroutine_ end block
call psb_errpush(info,name,a_err='psb_halo') end if
goto 9999
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 end if
call x%cnv(mold) if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -202,7 +246,7 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch)
else else
do i=1, n do i=1, n
dupl_ = x(i)%get_dupl() dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info) call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit if (info /= 0) exit
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x(i),desc_a,info) 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 logical, intent(in), optional :: local
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_ integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,info) call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -198,7 +198,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local logical, intent(in), optional :: local
!locals..... !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 integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me 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.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,info) call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -368,7 +368,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then

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

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory) ! 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_base_mod, psb_protect_name => psb_zspasb
use psb_sort_mod use psb_sort_mod
use psi_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 character(len=*), optional, intent(in) :: afmt
class(psb_z_base_sparse_mat), intent(in), optional :: mold class(psb_z_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
!....Locals.... !....Locals....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act integer(psb_ipk_) :: np,me, err_act
@ -103,7 +104,12 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
!check on errors encountered in psdspins !check on errors encountered in psdspins
if (a%is_bld()) then if (a%is_bld()) then
dupl_ = a%get_dupl() if (present(dupl)) then
dupl_ = dupl
else
dupl_ = a%get_dupl()
end if
! !
! First case: we come from a fresh build. ! First case: we come from a fresh build.
! !
@ -180,7 +186,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
if (bld_and_) then if (bld_and_) then
!!$ allocate(a%ad,mold=a%a) !!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o !!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info) !!$ call a%split_nd(n_row,n_col,info)
!!$ block !!$ block
!!$ character(len=1024) :: fname !!$ character(len=1024) :: fname
!!$ type(psb_z_coo_sparse_mat) :: acoo !!$ 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_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_zero(psb_c_cvector *xh);
psb_i_t *psb_c_cvect_f_get_pnt(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(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(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_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_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_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_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(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_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); 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_f_get_cpy(psb_d_t *v, psb_c_dvector *xh);
psb_i_t psb_c_dvect_zero(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_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(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(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_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_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_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_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(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_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); 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_f_get_cpy(psb_s_t *v, psb_c_svector *xh);
psb_i_t psb_c_svect_zero(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_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(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(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_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_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_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_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(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_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); 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 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 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 return
end function psb_c_cgeall_remote 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) function psb_c_cgeasb(xh,cdh) bind(c) result(res)
implicit none implicit none
@ -97,6 +129,38 @@ contains
return return
end function psb_c_cgeasb 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) function psb_c_cgefree(xh,cdh) bind(c) result(res)
implicit none 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_f_get_cpy(psb_z_t *v, psb_c_zvector *xh);
psb_i_t psb_c_zvect_zero(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_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(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(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_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_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_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_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(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_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); 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 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 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 return
end function psb_c_dgeall_remote 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) function psb_c_dgeasb(xh,cdh) bind(c) result(res)
implicit none implicit none
@ -97,6 +129,38 @@ contains
return return
end function psb_c_dgeasb 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) function psb_c_dgefree(xh,cdh) bind(c) result(res)
implicit none 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 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 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 return
end function psb_c_sgeall_remote 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) function psb_c_sgeasb(xh,cdh) bind(c) result(res)
implicit none implicit none
@ -97,6 +129,38 @@ contains
return return
end function psb_c_sgeasb 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) function psb_c_sgefree(xh,cdh) bind(c) result(res)
implicit none 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 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 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 return
end function psb_c_zgeall_remote 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) function psb_c_zgeasb(xh,cdh) bind(c) result(res)
implicit none implicit none
@ -97,6 +129,38 @@ contains
return return
end function psb_c_zgeasb 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) function psb_c_zgefree(xh,cdh) bind(c) result(res)
implicit none 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 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 use psb_base_mod
complex(psb_spk_), intent(in) :: this(:) complex(psb_spk_), intent(in) :: this(:)
class(psb_c_vect_cuda), intent(inout) :: x class(psb_c_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -578,11 +586,19 @@ contains
end subroutine c_cuda_bld_x 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 integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_cuda), intent(inout) :: x class(psb_c_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info) call x%all(n,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'c_cuda_bld_n',i_err=(/n,n,n,n,n/)) 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) call x%set_scal(czero)
end subroutine c_cuda_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_cuda), intent(inout) :: x class(psb_c_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect) nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then if (nd < n) then
call x%sync() 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
else ! else !
if (x%get_nrows()<n) then 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
@ -1252,11 +1276,11 @@ contains
call x%free(info) call x%free(info)
end subroutine c_cuda_vect_finalize 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 use psi_serial_mod
implicit none implicit none
class(psb_c_vect_cuda), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_c_base_vect_type), intent(inout) :: val class(psb_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -1295,11 +1319,11 @@ contains
end subroutine c_cuda_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_c_vect_cuda), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine c_cuda_ins_a 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 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 use psb_base_mod
real(psb_dpk_), intent(in) :: this(:) real(psb_dpk_), intent(in) :: this(:)
class(psb_d_vect_cuda), intent(inout) :: x class(psb_d_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -578,11 +586,19 @@ contains
end subroutine d_cuda_bld_x 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 integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_cuda), intent(inout) :: x class(psb_d_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info) call x%all(n,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'d_cuda_bld_n',i_err=(/n,n,n,n,n/)) 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) call x%set_scal(dzero)
end subroutine d_cuda_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_cuda), intent(inout) :: x class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect) nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then if (nd < n) then
call x%sync() 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
else ! else !
if (x%get_nrows()<n) then 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
@ -1252,11 +1276,11 @@ contains
call x%free(info) call x%free(info)
end subroutine d_cuda_vect_finalize end subroutine d_cuda_vect_finalize
subroutine d_cuda_ins_v(n,irl,val,dupl,x,info) subroutine d_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_cuda), intent(inout) :: x class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -1295,11 +1319,11 @@ contains
end subroutine d_cuda_ins_v end subroutine d_cuda_ins_v
subroutine d_cuda_ins_a(n,irl,val,dupl,x,info) subroutine d_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_cuda), intent(inout) :: x class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
call x%psb_d_base_vect_type%ins(n,irl,val,dupl,info) call x%psb_d_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host() call x%set_host()
end subroutine d_cuda_ins_a end subroutine d_cuda_ins_a

48
cuda/psb_i_cuda_vect_mod.F90
Unescape Escape View File

@ -542,12 +542,20 @@ contains
end subroutine i_cuda_sctb_buf 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 use psb_base_mod
integer(psb_ipk_), intent(in) :: this(:) integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_vect_cuda), intent(inout) :: x class(psb_i_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -560,11 +568,19 @@ contains
end subroutine i_cuda_bld_x 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 integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_cuda), intent(inout) :: x class(psb_i_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info) call x%all(n,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'i_cuda_bld_n',i_err=(/n,n,n,n,n/)) 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) call x%set_scal(izero)
end subroutine i_cuda_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_cuda), intent(inout) :: x class(psb_i_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect) nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then if (nd < n) then
call x%sync() 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
else ! else !
if (x%get_nrows()<n) then 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
@ -814,11 +838,11 @@ contains
call x%free(info) call x%free(info)
end subroutine i_cuda_vect_finalize 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 use psi_serial_mod
implicit none implicit none
class(psb_i_vect_cuda), intent(inout) :: x 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) :: irl
class(psb_i_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -847,7 +871,7 @@ contains
if (.not.done_cuda) then if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -857,11 +881,11 @@ contains
end subroutine i_cuda_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_i_vect_cuda), intent(inout) :: x 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) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -870,7 +894,7 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine i_cuda_ins_a 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 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 use psb_base_mod
real(psb_spk_), intent(in) :: this(:) real(psb_spk_), intent(in) :: this(:)
class(psb_s_vect_cuda), intent(inout) :: x class(psb_s_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -578,11 +586,19 @@ contains
end subroutine s_cuda_bld_x 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 integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_cuda), intent(inout) :: x class(psb_s_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info) call x%all(n,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'s_cuda_bld_n',i_err=(/n,n,n,n,n/)) 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) call x%set_scal(szero)
end subroutine s_cuda_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_cuda), intent(inout) :: x class(psb_s_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect) nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then if (nd < n) then
call x%sync() 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
else ! else !
if (x%get_nrows()<n) then 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
@ -1252,11 +1276,11 @@ contains
call x%free(info) call x%free(info)
end subroutine s_cuda_vect_finalize 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 use psi_serial_mod
implicit none implicit none
class(psb_s_vect_cuda), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_s_base_vect_type), intent(inout) :: val class(psb_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -1295,11 +1319,11 @@ contains
end subroutine s_cuda_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_s_vect_cuda), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine s_cuda_ins_a 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 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 use psb_base_mod
complex(psb_dpk_), intent(in) :: this(:) complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_vect_cuda), intent(inout) :: x class(psb_z_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -578,11 +586,19 @@ contains
end subroutine z_cuda_bld_x 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 integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_cuda), intent(inout) :: x class(psb_z_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info) call x%all(n,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'z_cuda_bld_n',i_err=(/n,n,n,n,n/)) 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) call x%set_scal(zzero)
end subroutine z_cuda_zero 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_cuda), intent(inout) :: x class(psb_z_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect) nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then if (nd < n) then
call x%sync() 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
else ! else !
if (x%get_nrows()<n) then 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) if (info == psb_success_) call x%sync_space(info)
call x%set_host() call x%set_host()
end if end if
@ -1252,11 +1276,11 @@ contains
call x%free(info) call x%free(info)
end subroutine z_cuda_vect_finalize 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 use psi_serial_mod
implicit none implicit none
class(psb_z_vect_cuda), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_z_base_vect_type), intent(inout) :: val class(psb_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync() if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info) call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -1295,11 +1319,11 @@ contains
end subroutine z_cuda_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_z_vect_cuda), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine z_cuda_ins_a 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 inner_gth
end subroutine c_oacc_gthzv_x 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 use psi_serial_mod
implicit none implicit none
class(psb_c_vect_oacc), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_c_base_vect_type), intent(inout) :: val class(psb_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_c_vect_oacc) type is (psb_c_vect_oacc)
if (vval%is_dev()) call vval%sync() if (vval%is_dev()) call vval%sync()
end select end select
call x%ins(n, irl%v, val%v, dupl, info) call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -671,11 +671,11 @@ contains
end subroutine c_oacc_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_c_vect_oacc), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -684,19 +684,26 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine c_oacc_ins_a 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_oacc), intent(inout) :: x class(psb_c_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call x%all(ione*n, info) call x%all(ione*n, info)
if (info /= 0) then if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine c_oacc_bld_mn 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 use psb_base_mod
implicit none implicit none
complex(psb_spk_), intent(in) :: this(:) complex(psb_spk_), intent(in) :: this(:)
class(psb_c_vect_oacc), intent(inout) :: x class(psb_c_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call psb_realloc(size(this), x%v, info) call psb_realloc(size(this), x%v, info)
if (info /= 0) then if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine c_oacc_bld_x 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_oacc), intent(inout) :: x class(psb_c_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = size(x%v) nd = size(x%v)
if (nd < n) then if (nd < n) then
call x%sync() 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if end if
else else
if (size(x%v) < n) then 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if 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 inner_gth
end subroutine d_oacc_gthzv_x end subroutine d_oacc_gthzv_x
subroutine d_oacc_ins_v(n, irl, val, dupl, x, info) subroutine d_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_oacc), intent(inout) :: x class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_d_vect_oacc) type is (psb_d_vect_oacc)
if (vval%is_dev()) call vval%sync() if (vval%is_dev()) call vval%sync()
end select end select
call x%ins(n, irl%v, val%v, dupl, info) call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -671,11 +671,11 @@ contains
end subroutine d_oacc_ins_v end subroutine d_oacc_ins_v
subroutine d_oacc_ins_a(n, irl, val, dupl, x, info) subroutine d_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_oacc), intent(inout) :: x class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -684,19 +684,26 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
call x%psb_d_base_vect_type%ins(n, irl, val, dupl, info) call x%psb_d_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host() call x%set_host()
end subroutine d_oacc_ins_a 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_oacc), intent(inout) :: x class(psb_d_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call x%all(ione*n, info) call x%all(ione*n, info)
if (info /= 0) then if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine d_oacc_bld_mn 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 use psb_base_mod
implicit none implicit none
real(psb_dpk_), intent(in) :: this(:) real(psb_dpk_), intent(in) :: this(:)
class(psb_d_vect_oacc), intent(inout) :: x class(psb_d_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call psb_realloc(size(this), x%v, info) call psb_realloc(size(this), x%v, info)
if (info /= 0) then if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine d_oacc_bld_x 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_oacc), intent(inout) :: x class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = size(x%v) nd = size(x%v)
if (nd < n) then if (nd < n) then
call x%sync() 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if end if
else else
if (size(x%v) < n) then 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if 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 inner_gth
end subroutine i_oacc_gthzv_x 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 use psi_serial_mod
implicit none implicit none
class(psb_i_vect_oacc), intent(inout) :: x 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) :: irl
class(psb_i_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -315,7 +315,7 @@ contains
type is (psb_i_vect_oacc) type is (psb_i_vect_oacc)
if (vval%is_dev()) call vval%sync() if (vval%is_dev()) call vval%sync()
end select end select
call x%ins(n, irl%v, val%v, dupl, info) call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -325,11 +325,11 @@ contains
end subroutine i_oacc_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_i_vect_oacc), intent(inout) :: x 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) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -338,19 +338,26 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine i_oacc_ins_a 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_oacc), intent(inout) :: x class(psb_i_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call x%all(ione*n, info) call x%all(ione*n, info)
if (info /= 0) then if (info /= 0) then
@ -363,13 +370,21 @@ contains
end subroutine i_oacc_bld_mn 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 use psb_base_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: this(:) integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_vect_oacc), intent(inout) :: x class(psb_i_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call psb_realloc(size(this), x%v, info) call psb_realloc(size(this), x%v, info)
if (info /= 0) then if (info /= 0) then
@ -384,27 +399,35 @@ contains
end subroutine i_oacc_bld_x 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_oacc), intent(inout) :: x class(psb_i_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = size(x%v) nd = size(x%v)
if (nd < n) then if (nd < n) then
call x%sync() 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if end if
else else
if (size(x%v) < n) then 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if 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 inner_gth
end subroutine l_oacc_gthzv_x 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 use psi_serial_mod
implicit none implicit none
class(psb_l_vect_oacc), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_l_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -317,7 +317,7 @@ contains
type is (psb_l_vect_oacc) type is (psb_l_vect_oacc)
if (vval%is_dev()) call vval%sync() if (vval%is_dev()) call vval%sync()
end select end select
call x%ins(n, irl%v, val%v, dupl, info) call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -327,11 +327,11 @@ contains
end subroutine l_oacc_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_l_vect_oacc), intent(inout) :: x 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_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -340,19 +340,26 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine l_oacc_ins_a 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_oacc), intent(inout) :: x class(psb_l_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call x%all(ione*n, info) call x%all(ione*n, info)
if (info /= 0) then if (info /= 0) then
@ -365,13 +372,21 @@ contains
end subroutine l_oacc_bld_mn 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 use psb_base_mod
implicit none implicit none
integer(psb_lpk_), intent(in) :: this(:) integer(psb_lpk_), intent(in) :: this(:)
class(psb_l_vect_oacc), intent(inout) :: x class(psb_l_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call psb_realloc(size(this), x%v, info) call psb_realloc(size(this), x%v, info)
if (info /= 0) then if (info /= 0) then
@ -386,27 +401,35 @@ contains
end subroutine l_oacc_bld_x 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_oacc), intent(inout) :: x class(psb_l_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = size(x%v) nd = size(x%v)
if (nd < n) then if (nd < n) then
call x%sync() 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if end if
else else
if (size(x%v) < n) then 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if 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 inner_gth
end subroutine s_oacc_gthzv_x 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 use psi_serial_mod
implicit none implicit none
class(psb_s_vect_oacc), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_s_base_vect_type), intent(inout) :: val class(psb_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_s_vect_oacc) type is (psb_s_vect_oacc)
if (vval%is_dev()) call vval%sync() if (vval%is_dev()) call vval%sync()
end select end select
call x%ins(n, irl%v, val%v, dupl, info) call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -671,11 +671,11 @@ contains
end subroutine s_oacc_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_s_vect_oacc), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -684,19 +684,26 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine s_oacc_ins_a 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_oacc), intent(inout) :: x class(psb_s_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call x%all(ione*n, info) call x%all(ione*n, info)
if (info /= 0) then if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine s_oacc_bld_mn 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 use psb_base_mod
implicit none implicit none
real(psb_spk_), intent(in) :: this(:) real(psb_spk_), intent(in) :: this(:)
class(psb_s_vect_oacc), intent(inout) :: x class(psb_s_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call psb_realloc(size(this), x%v, info) call psb_realloc(size(this), x%v, info)
if (info /= 0) then if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine s_oacc_bld_x 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_oacc), intent(inout) :: x class(psb_s_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = size(x%v) nd = size(x%v)
if (nd < n) then if (nd < n) then
call x%sync() 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if end if
else else
if (size(x%v) < n) then 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if 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 inner_gth
end subroutine z_oacc_gthzv_x 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 use psi_serial_mod
implicit none implicit none
class(psb_z_vect_oacc), intent(inout) :: x 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_i_base_vect_type), intent(inout) :: irl
class(psb_z_base_vect_type), intent(inout) :: val class(psb_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_z_vect_oacc) type is (psb_z_vect_oacc)
if (vval%is_dev()) call vval%sync() if (vval%is_dev()) call vval%sync()
end select end select
call x%ins(n, irl%v, val%v, dupl, info) call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if end if
if (info /= 0) then if (info /= 0) then
@ -671,11 +671,11 @@ contains
end subroutine z_oacc_ins_v 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 use psi_serial_mod
implicit none implicit none
class(psb_z_vect_oacc), intent(inout) :: x 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(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -684,19 +684,26 @@ contains
info = 0 info = 0
if (x%is_dev()) call x%sync() 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() call x%set_host()
end subroutine z_oacc_ins_a 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_oacc), intent(inout) :: x class(psb_z_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call x%all(ione*n, info) call x%all(ione*n, info)
if (info /= 0) then if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine z_oacc_bld_mn 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 use psb_base_mod
implicit none implicit none
complex(psb_dpk_), intent(in) :: this(:) complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_vect_oacc), intent(inout) :: x class(psb_z_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info) call x%free(info)
call psb_realloc(size(this), x%v, info) call psb_realloc(size(this), x%v, info)
if (info /= 0) then if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine z_oacc_bld_x 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 use psb_base_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_oacc), intent(inout) :: x class(psb_z_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd integer(psb_mpk_) :: nd
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then if (x%is_dev()) then
nd = size(x%v) nd = size(x%v)
if (nd < n) then if (nd < n) then
call x%sync() 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if end if
else else
if (size(x%v) < n) then 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() if (info == psb_success_) call x%sync()
call x%set_host() call x%set_host()
end if 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,& 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 ! 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(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,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) call psb_barrier(ctxt)
talc = psb_wtime()-t0 talc = psb_wtime()-t0
@ -558,9 +558,9 @@ contains
t1 = psb_wtime() t1 = psb_wtime()
if (info == psb_success_) then if (info == psb_success_) then
if (present(amold)) then if (present(amold)) then
call psb_spasb(a,desc_a,info,mold=amold) call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_)
else else
call psb_spasb(a,desc_a,info,afmt=afmt) call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_)
end if end if
end if end if
call psb_barrier(ctxt) call psb_barrier(ctxt)
@ -570,8 +570,8 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold) if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold) if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='asb rout.' ch_err='asb rout.'

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

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,& 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 ! 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(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,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) call psb_barrier(ctxt)
talc = psb_wtime()-t0 talc = psb_wtime()-t0
@ -558,9 +558,9 @@ contains
t1 = psb_wtime() t1 = psb_wtime()
if (info == psb_success_) then if (info == psb_success_) then
if (present(amold)) then if (present(amold)) then
call psb_spasb(a,desc_a,info,mold=amold) call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_)
else else
call psb_spasb(a,desc_a,info,afmt=afmt) call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_)
end if end if
end if end if
call psb_barrier(ctxt) call psb_barrier(ctxt)
@ -570,8 +570,8 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold) if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold) if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='asb rout.' ch_err='asb rout.'

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

Write Preview
Loading…
Cancel
Save