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

Working version with mods for building with dealii requests

Browse Source
pull/31/head
sfilippone 6 months ago
parent 98a6eba948
commit 0c84efb887
56 changed files with 3760 additions and 893 deletions
Show Stats Download Patch File Download Diff File

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

@ -332,7 +332,7 @@ module psb_const_mod
contains
procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt
end type psb_ctxt_type
logical, parameter :: try_newins=.true.
contains
function psb_cmp_ctxt(ctxt1, ctxt2) result(res)

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

@ -65,6 +65,18 @@ module psb_c_base_vect_mod
complex(psb_spk_), allocatable :: v(:)
complex(psb_spk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@ -88,6 +100,21 @@ module psb_c_base_vect_mod
procedure, pass(x) :: asb_e => c_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => c_base_free
procedure, pass(x) :: reinit => c_base_reinit
procedure, pass(x) :: set_ncfs => c_base_set_ncfs
procedure, pass(x) :: get_ncfs => c_base_get_ncfs
procedure, pass(x) :: set_dupl => c_base_set_dupl
procedure, pass(x) :: get_dupl => c_base_get_dupl
procedure, pass(x) :: set_state => c_base_set_state
procedure, pass(x) :: set_null => c_base_set_null
procedure, pass(x) :: set_bld => c_base_set_bld
procedure, pass(x) :: set_upd => c_base_set_upd
procedure, pass(x) :: set_asb => c_base_set_asb
procedure, pass(x) :: get_state => c_base_get_state
procedure, pass(x) :: is_null => c_base_is_null
procedure, pass(x) :: is_bld => c_base_is_bld
procedure, pass(x) :: is_upd => c_base_is_upd
procedure, pass(x) :: is_asb => c_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -211,8 +238,6 @@ module psb_c_base_vect_mod
generic, public :: addconst => addconst_a2,addconst_v2
end type psb_c_base_vect_type
public :: psb_c_base_vect
@ -263,14 +288,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine c_base_bld_x(x,this)
subroutine c_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
complex(psb_spk_), intent(in) :: this(:)
class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -295,15 +328,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine c_base_bld_mn(x,n)
subroutine c_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine c_base_bld_mn
@ -312,15 +353,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine c_base_bld_en(x,n)
subroutine c_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine c_base_bld_en
@ -340,9 +389,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine c_base_all
subroutine c_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_c_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = czero
call x%set_host()
call x%set_upd()
end if
end subroutine c_base_reinit
!> Function base_mold:
!! \memberof psb_c_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@ -388,55 +457,116 @@ contains
!! \param info return code
!!
!
subroutine c_base_ins_a(n,irl,val,dupl,x,info)
subroutine c_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
call x%set_ncfs(k)
else if (x%is_upd()) then
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@ -446,11 +576,11 @@ contains
end subroutine c_base_ins_a
subroutine c_base_ins_v(n,irl,val,dupl,x,info)
subroutine c_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -463,7 +593,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@ -507,19 +637,70 @@ contains
!!
!
subroutine c_base_asb_m(n, x, info)
subroutine c_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_spk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine c_base_asb_m
@ -537,19 +718,70 @@ contains
!!
!
subroutine c_base_asb_e(n, x, info)
subroutine c_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_spk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine c_base_asb_e
@ -572,9 +804,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine c_base_free
@ -637,7 +870,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine c_base_free_comid
function c_base_get_ncfs(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function c_base_get_ncfs
function c_base_get_dupl(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function c_base_get_dupl
function c_base_get_state(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function c_base_get_state
function c_base_is_null(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function c_base_is_null
function c_base_is_bld(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function c_base_is_bld
function c_base_is_upd(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function c_base_is_upd
function c_base_is_asb(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function c_base_is_asb
subroutine c_base_set_ncfs(n,x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine c_base_set_ncfs
subroutine c_base_set_dupl(n,x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine c_base_set_dupl
subroutine c_base_set_state(n,x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine c_base_set_state
subroutine c_base_set_null(x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine c_base_set_null
subroutine c_base_set_bld(x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine c_base_set_bld
subroutine c_base_set_upd(x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine c_base_set_upd
subroutine c_base_set_asb(x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine c_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just

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

@ -56,14 +56,26 @@ module psb_c_vect_mod
procedure, pass(x) :: get_fmt => c_vect_get_fmt
procedure, pass(x) :: is_remote_build => c_vect_is_remote_build
procedure, pass(x) :: set_remote_build => c_vect_set_remote_build
procedure, pass(x) :: get_dupl => c_vect_get_dupl
procedure, pass(x) :: set_dupl => c_vect_set_dupl
procedure, pass(x) :: get_nrmv => c_vect_get_nrmv
procedure, pass(x) :: set_nrmv => c_vect_set_nrmv
procedure, pass(x) :: all => c_vect_all
procedure, pass(x) :: reall => c_vect_reall
procedure, pass(x) :: zero => c_vect_zero
procedure, pass(x) :: asb => c_vect_asb
procedure, pass(x) :: set_dupl => c_vect_set_dupl
procedure, pass(x) :: get_dupl => c_vect_get_dupl
procedure, pass(x) :: set_state => c_vect_set_state
procedure, pass(x) :: set_null => c_vect_set_null
procedure, pass(x) :: set_bld => c_vect_set_bld
procedure, pass(x) :: set_upd => c_vect_set_upd
procedure, pass(x) :: set_asb => c_vect_set_asb
procedure, pass(x) :: get_state => c_vect_get_state
procedure, pass(x) :: is_null => c_vect_is_null
procedure, pass(x) :: is_bld => c_vect_is_bld
procedure, pass(x) :: is_upd => c_vect_is_upd
procedure, pass(x) :: is_asb => c_vect_is_asb
procedure, pass(x) :: reinit => c_vect_reinit
procedure, pass(x) :: gthab => c_vect_gthab
procedure, pass(x) :: gthzv => c_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -187,7 +199,11 @@ contains
implicit none
class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function c_vect_get_dupl
subroutine c_vect_set_dupl(x,val)
@ -195,13 +211,92 @@ contains
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine c_vect_set_dupl
function c_vect_get_state(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function c_vect_get_state
function c_vect_is_null(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function c_vect_is_null
function c_vect_is_bld(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function c_vect_is_bld
function c_vect_is_upd(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function c_vect_is_upd
function c_vect_is_asb(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function c_vect_is_asb
subroutine c_vect_set_state(n,x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine c_vect_set_state
subroutine c_vect_set_null(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine c_vect_set_null
subroutine c_vect_set_bld(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine c_vect_set_bld
subroutine c_vect_set_upd(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine c_vect_set_upd
subroutine c_vect_set_asb(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine c_vect_set_asb
function c_vect_get_nrmv(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
@ -291,12 +386,21 @@ contains
end if
end subroutine c_vect_clone
subroutine c_vect_bld_x(x,invect,mold)
subroutine c_vect_bld_x(x,invect,mold,scratch)
complex(psb_spk_), intent(in) :: invect(:)
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@ -307,17 +411,25 @@ contains
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine c_vect_bld_x
subroutine c_vect_bld_mn(x,n,mold)
subroutine c_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@ -328,17 +440,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine c_vect_bld_mn
subroutine c_vect_bld_en(x,n,mold)
subroutine c_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@ -348,7 +468,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine c_vect_bld_en
@ -450,8 +570,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine c_vect_all
subroutine c_vect_reinit(x, info)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine c_vect_reinit
subroutine c_vect_reall(n, x, info)
implicit none
@ -476,16 +607,17 @@ contains
end subroutine c_vect_zero
subroutine c_vect_asb(n, x, info)
subroutine c_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine c_vect_asb
@ -540,11 +672,11 @@ contains
end subroutine c_vect_free
subroutine c_vect_ins_a(n,irl,val,x,info)
subroutine c_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -557,15 +689,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine c_vect_ins_a
subroutine c_vect_ins_v(n,irl,val,x,info)
subroutine c_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -578,7 +710,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine c_vect_ins_v

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

@ -73,9 +73,9 @@ module psb_d_base_vect_mod
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
@ -89,15 +89,17 @@ module psb_d_base_vect_mod
procedure, pass(x) :: mold => d_base_mold
!
! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
! in derived classes.
!
procedure, pass(x) :: ins_a => d_base_ins_a
procedure, pass(x) :: ins_v => d_base_ins_v
generic, public :: ins => ins_a, ins_v
procedure, pass(x) :: zero => d_base_zero
procedure, pass(x) :: asb_m => d_base_asb_m
procedure, pass(x) :: asb_e => d_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => d_base_free
procedure, pass(x) :: ins_a => d_base_ins_a
procedure, pass(x) :: ins_v => d_base_ins_v
generic, public :: ins => ins_a, ins_v
procedure, pass(x) :: zero => d_base_zero
procedure, pass(x) :: asb_m => d_base_asb_m
procedure, pass(x) :: asb_e => d_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => d_base_free
procedure, pass(x) :: reinit => d_base_reinit
procedure, pass(x) :: set_ncfs => d_base_set_ncfs
procedure, pass(x) :: get_ncfs => d_base_get_ncfs
@ -243,8 +245,6 @@ module psb_d_base_vect_mod
procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2
generic, public :: minquotient => minquotient_v, minquotient_a2
end type psb_d_base_vect_type
public :: psb_d_base_vect
@ -253,7 +253,6 @@ module psb_d_base_vect_mod
module procedure constructor, size_const
end interface psb_d_base_vect
logical, parameter :: try_newins=.true.
contains
!
@ -296,14 +295,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine d_base_bld_x(x,this)
subroutine d_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
real(psb_dpk_), intent(in) :: this(:)
class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -328,15 +335,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine d_base_bld_mn(x,n)
subroutine d_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine d_base_bld_mn
@ -345,15 +360,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine d_base_bld_en(x,n)
subroutine d_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine d_base_bld_en
@ -373,10 +396,10 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
#ifdef TRY_NEWINS
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
#endif
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine d_base_all
@ -391,6 +414,7 @@ contains
call x%sync()
x%v(:) = dzero
call x%set_host()
call x%set_upd()
end if
end subroutine d_base_reinit
@ -444,7 +468,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -453,56 +477,97 @@ contains
info = 0
if (psb_errstatus_fatal()) return
#ifdef TRY_NEWINS
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(k) = val(i)
x%iv(k) = irl(i)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
call x%set_ncfs(k)
else if (x%is_upd()) then
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
enddo
call x%set_ncfs(k)
else
info = psb_err_invalid_vect_state_
end if
else
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
@ -510,44 +575,6 @@ contains
end select
end if
end if
#else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
#endif
call x%set_host()
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@ -560,7 +587,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -617,17 +644,25 @@ contains
!!
!
subroutine d_base_asb_m(n, x, info)
subroutine d_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,ncfs,xvsz
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_dpk_), allocatable :: vv(:)
info = 0
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
@ -658,11 +693,14 @@ contains
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
@ -687,17 +725,25 @@ contains
!!
!
subroutine d_base_asb_e(n, x, info)
subroutine d_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_dpk_), allocatable :: vv(:)
info = 0
info = 0
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
@ -728,11 +774,14 @@ contains
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
@ -741,7 +790,6 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine d_base_asb_e
!
@ -763,9 +811,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine d_base_free
@ -828,7 +877,7 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine d_base_free_comid
function d_base_get_ncfs(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
@ -926,7 +975,7 @@ contains
x%bldstate = psb_vect_asb_
end subroutine d_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just
! a placeholder.

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

@ -45,8 +45,9 @@ module psb_d_vect_mod
type psb_d_vect_type
class(psb_d_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build = psb_matbld_noremote_
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
real(psb_dpk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:)
contains
@ -74,7 +75,7 @@ module psb_d_vect_mod
procedure, pass(x) :: is_upd => d_vect_is_upd
procedure, pass(x) :: is_asb => d_vect_is_asb
procedure, pass(x) :: reinit => d_vect_reinit
procedure, pass(x) :: gthab => d_vect_gthab
procedure, pass(x) :: gthzv => d_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -303,7 +304,6 @@ contains
call x%set_state(psb_vect_asb_)
end subroutine d_vect_set_asb
function d_vect_get_nrmv(x) result(res)
implicit none
class(psb_d_vect_type), intent(in) :: x
@ -393,12 +393,21 @@ contains
end if
end subroutine d_vect_clone
subroutine d_vect_bld_x(x,invect,mold)
subroutine d_vect_bld_x(x,invect,mold,scratch)
real(psb_dpk_), intent(in) :: invect(:)
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@ -409,17 +418,25 @@ contains
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine d_vect_bld_x
subroutine d_vect_bld_mn(x,n,mold)
subroutine d_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@ -430,17 +447,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine d_vect_bld_mn
subroutine d_vect_bld_en(x,n,mold)
subroutine d_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@ -450,7 +475,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine d_vect_bld_en
@ -556,7 +581,6 @@ contains
end subroutine d_vect_all
subroutine d_vect_reinit(x, info)
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
@ -565,7 +589,7 @@ contains
call x%set_upd()
end subroutine d_vect_reinit
subroutine d_vect_reall(n, x, info)
implicit none
@ -590,16 +614,17 @@ contains
end subroutine d_vect_zero
subroutine d_vect_asb(n, x, info)
subroutine d_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine d_vect_asb
@ -658,7 +683,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n,maxr
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -679,7 +704,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n,maxr
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info

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

@ -63,6 +63,18 @@ module psb_i_base_vect_mod
integer(psb_ipk_), allocatable :: v(:)
integer(psb_ipk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@ -86,6 +98,21 @@ module psb_i_base_vect_mod
procedure, pass(x) :: asb_e => i_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => i_base_free
procedure, pass(x) :: reinit => i_base_reinit
procedure, pass(x) :: set_ncfs => i_base_set_ncfs
procedure, pass(x) :: get_ncfs => i_base_get_ncfs
procedure, pass(x) :: set_dupl => i_base_set_dupl
procedure, pass(x) :: get_dupl => i_base_get_dupl
procedure, pass(x) :: set_state => i_base_set_state
procedure, pass(x) :: set_null => i_base_set_null
procedure, pass(x) :: set_bld => i_base_set_bld
procedure, pass(x) :: set_upd => i_base_set_upd
procedure, pass(x) :: set_asb => i_base_set_asb
procedure, pass(x) :: get_state => i_base_get_state
procedure, pass(x) :: is_null => i_base_is_null
procedure, pass(x) :: is_bld => i_base_is_bld
procedure, pass(x) :: is_upd => i_base_is_upd
procedure, pass(x) :: is_asb => i_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -144,8 +171,6 @@ module psb_i_base_vect_mod
end type psb_i_base_vect_type
public :: psb_i_base_vect
@ -196,14 +221,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine i_base_bld_x(x,this)
subroutine i_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -228,15 +261,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine i_base_bld_mn(x,n)
subroutine i_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine i_base_bld_mn
@ -245,15 +286,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine i_base_bld_en(x,n)
subroutine i_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine i_base_bld_en
@ -273,9 +322,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine i_base_all
subroutine i_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = izero
call x%set_host()
call x%set_upd()
end if
end subroutine i_base_reinit
!> Function base_mold:
!! \memberof psb_i_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@ -321,55 +390,116 @@ contains
!! \param info return code
!!
!
subroutine i_base_ins_a(n,irl,val,dupl,x,info)
subroutine i_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
call x%set_ncfs(k)
else if (x%is_upd()) then
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@ -379,11 +509,11 @@ contains
end subroutine i_base_ins_a
subroutine i_base_ins_v(n,irl,val,dupl,x,info)
subroutine i_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -396,7 +526,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@ -440,19 +570,70 @@ contains
!!
!
subroutine i_base_asb_m(n, x, info)
subroutine i_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_ipk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine i_base_asb_m
@ -470,19 +651,70 @@ contains
!!
!
subroutine i_base_asb_e(n, x, info)
subroutine i_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_ipk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine i_base_asb_e
@ -505,9 +737,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine i_base_free
@ -570,7 +803,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine i_base_free_comid
function i_base_get_ncfs(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function i_base_get_ncfs
function i_base_get_dupl(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function i_base_get_dupl
function i_base_get_state(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function i_base_get_state
function i_base_is_null(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function i_base_is_null
function i_base_is_bld(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function i_base_is_bld
function i_base_is_upd(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function i_base_is_upd
function i_base_is_asb(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function i_base_is_asb
subroutine i_base_set_ncfs(n,x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine i_base_set_ncfs
subroutine i_base_set_dupl(n,x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine i_base_set_dupl
subroutine i_base_set_state(n,x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine i_base_set_state
subroutine i_base_set_null(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine i_base_set_null
subroutine i_base_set_bld(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine i_base_set_bld
subroutine i_base_set_upd(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine i_base_set_upd
subroutine i_base_set_asb(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine i_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just

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

@ -55,14 +55,26 @@ module psb_i_vect_mod
procedure, pass(x) :: get_fmt => i_vect_get_fmt
procedure, pass(x) :: is_remote_build => i_vect_is_remote_build
procedure, pass(x) :: set_remote_build => i_vect_set_remote_build
procedure, pass(x) :: get_dupl => i_vect_get_dupl
procedure, pass(x) :: set_dupl => i_vect_set_dupl
procedure, pass(x) :: get_nrmv => i_vect_get_nrmv
procedure, pass(x) :: set_nrmv => i_vect_set_nrmv
procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: reall => i_vect_reall
procedure, pass(x) :: zero => i_vect_zero
procedure, pass(x) :: asb => i_vect_asb
procedure, pass(x) :: set_dupl => i_vect_set_dupl
procedure, pass(x) :: get_dupl => i_vect_get_dupl
procedure, pass(x) :: set_state => i_vect_set_state
procedure, pass(x) :: set_null => i_vect_set_null
procedure, pass(x) :: set_bld => i_vect_set_bld
procedure, pass(x) :: set_upd => i_vect_set_upd
procedure, pass(x) :: set_asb => i_vect_set_asb
procedure, pass(x) :: get_state => i_vect_get_state
procedure, pass(x) :: is_null => i_vect_is_null
procedure, pass(x) :: is_bld => i_vect_is_bld
procedure, pass(x) :: is_upd => i_vect_is_upd
procedure, pass(x) :: is_asb => i_vect_is_asb
procedure, pass(x) :: reinit => i_vect_reinit
procedure, pass(x) :: gthab => i_vect_gthab
procedure, pass(x) :: gthzv => i_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -132,7 +144,11 @@ contains
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function i_vect_get_dupl
subroutine i_vect_set_dupl(x,val)
@ -140,13 +156,92 @@ contains
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine i_vect_set_dupl
function i_vect_get_state(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function i_vect_get_state
function i_vect_is_null(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function i_vect_is_null
function i_vect_is_bld(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function i_vect_is_bld
function i_vect_is_upd(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function i_vect_is_upd
function i_vect_is_asb(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function i_vect_is_asb
subroutine i_vect_set_state(n,x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine i_vect_set_state
subroutine i_vect_set_null(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine i_vect_set_null
subroutine i_vect_set_bld(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine i_vect_set_bld
subroutine i_vect_set_upd(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine i_vect_set_upd
subroutine i_vect_set_asb(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine i_vect_set_asb
function i_vect_get_nrmv(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
@ -236,12 +331,21 @@ contains
end if
end subroutine i_vect_clone
subroutine i_vect_bld_x(x,invect,mold)
subroutine i_vect_bld_x(x,invect,mold,scratch)
integer(psb_ipk_), intent(in) :: invect(:)
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@ -252,17 +356,25 @@ contains
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine i_vect_bld_x
subroutine i_vect_bld_mn(x,n,mold)
subroutine i_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@ -273,17 +385,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine i_vect_bld_mn
subroutine i_vect_bld_en(x,n,mold)
subroutine i_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@ -293,7 +413,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine i_vect_bld_en
@ -395,8 +515,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine i_vect_all
subroutine i_vect_reinit(x, info)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine i_vect_reinit
subroutine i_vect_reall(n, x, info)
implicit none
@ -421,16 +552,17 @@ contains
end subroutine i_vect_zero
subroutine i_vect_asb(n, x, info)
subroutine i_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine i_vect_asb
@ -485,11 +617,11 @@ contains
end subroutine i_vect_free
subroutine i_vect_ins_a(n,irl,val,x,info)
subroutine i_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -502,15 +634,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine i_vect_ins_a
subroutine i_vect_ins_v(n,irl,val,x,info)
subroutine i_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_i_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -523,7 +655,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine i_vect_ins_v

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

@ -64,6 +64,18 @@ module psb_l_base_vect_mod
integer(psb_lpk_), allocatable :: v(:)
integer(psb_lpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@ -87,6 +99,21 @@ module psb_l_base_vect_mod
procedure, pass(x) :: asb_e => l_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => l_base_free
procedure, pass(x) :: reinit => l_base_reinit
procedure, pass(x) :: set_ncfs => l_base_set_ncfs
procedure, pass(x) :: get_ncfs => l_base_get_ncfs
procedure, pass(x) :: set_dupl => l_base_set_dupl
procedure, pass(x) :: get_dupl => l_base_get_dupl
procedure, pass(x) :: set_state => l_base_set_state
procedure, pass(x) :: set_null => l_base_set_null
procedure, pass(x) :: set_bld => l_base_set_bld
procedure, pass(x) :: set_upd => l_base_set_upd
procedure, pass(x) :: set_asb => l_base_set_asb
procedure, pass(x) :: get_state => l_base_get_state
procedure, pass(x) :: is_null => l_base_is_null
procedure, pass(x) :: is_bld => l_base_is_bld
procedure, pass(x) :: is_upd => l_base_is_upd
procedure, pass(x) :: is_asb => l_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -145,8 +172,6 @@ module psb_l_base_vect_mod
end type psb_l_base_vect_type
public :: psb_l_base_vect
@ -197,14 +222,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine l_base_bld_x(x,this)
subroutine l_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
integer(psb_lpk_), intent(in) :: this(:)
class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -229,15 +262,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine l_base_bld_mn(x,n)
subroutine l_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine l_base_bld_mn
@ -246,15 +287,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine l_base_bld_en(x,n)
subroutine l_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine l_base_bld_en
@ -274,9 +323,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine l_base_all
subroutine l_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_l_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = lzero
call x%set_host()
call x%set_upd()
end if
end subroutine l_base_reinit
!> Function base_mold:
!! \memberof psb_l_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@ -322,55 +391,116 @@ contains
!! \param info return code
!!
!
subroutine l_base_ins_a(n,irl,val,dupl,x,info)
subroutine l_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
call x%set_ncfs(k)
else if (x%is_upd()) then
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@ -380,11 +510,11 @@ contains
end subroutine l_base_ins_a
subroutine l_base_ins_v(n,irl,val,dupl,x,info)
subroutine l_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_l_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -397,7 +527,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@ -441,19 +571,70 @@ contains
!!
!
subroutine l_base_asb_m(n, x, info)
subroutine l_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_lpk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine l_base_asb_m
@ -471,19 +652,70 @@ contains
!!
!
subroutine l_base_asb_e(n, x, info)
subroutine l_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_lpk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine l_base_asb_e
@ -506,9 +738,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine l_base_free
@ -571,7 +804,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine l_base_free_comid
function l_base_get_ncfs(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function l_base_get_ncfs
function l_base_get_dupl(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function l_base_get_dupl
function l_base_get_state(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function l_base_get_state
function l_base_is_null(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function l_base_is_null
function l_base_is_bld(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function l_base_is_bld
function l_base_is_upd(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function l_base_is_upd
function l_base_is_asb(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function l_base_is_asb
subroutine l_base_set_ncfs(n,x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine l_base_set_ncfs
subroutine l_base_set_dupl(n,x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine l_base_set_dupl
subroutine l_base_set_state(n,x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine l_base_set_state
subroutine l_base_set_null(x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine l_base_set_null
subroutine l_base_set_bld(x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine l_base_set_bld
subroutine l_base_set_upd(x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine l_base_set_upd
subroutine l_base_set_asb(x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine l_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just

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

@ -56,14 +56,26 @@ module psb_l_vect_mod
procedure, pass(x) :: get_fmt => l_vect_get_fmt
procedure, pass(x) :: is_remote_build => l_vect_is_remote_build
procedure, pass(x) :: set_remote_build => l_vect_set_remote_build
procedure, pass(x) :: get_dupl => l_vect_get_dupl
procedure, pass(x) :: set_dupl => l_vect_set_dupl
procedure, pass(x) :: get_nrmv => l_vect_get_nrmv
procedure, pass(x) :: set_nrmv => l_vect_set_nrmv
procedure, pass(x) :: all => l_vect_all
procedure, pass(x) :: reall => l_vect_reall
procedure, pass(x) :: zero => l_vect_zero
procedure, pass(x) :: asb => l_vect_asb
procedure, pass(x) :: set_dupl => l_vect_set_dupl
procedure, pass(x) :: get_dupl => l_vect_get_dupl
procedure, pass(x) :: set_state => l_vect_set_state
procedure, pass(x) :: set_null => l_vect_set_null
procedure, pass(x) :: set_bld => l_vect_set_bld
procedure, pass(x) :: set_upd => l_vect_set_upd
procedure, pass(x) :: set_asb => l_vect_set_asb
procedure, pass(x) :: get_state => l_vect_get_state
procedure, pass(x) :: is_null => l_vect_is_null
procedure, pass(x) :: is_bld => l_vect_is_bld
procedure, pass(x) :: is_upd => l_vect_is_upd
procedure, pass(x) :: is_asb => l_vect_is_asb
procedure, pass(x) :: reinit => l_vect_reinit
procedure, pass(x) :: gthab => l_vect_gthab
procedure, pass(x) :: gthzv => l_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -133,7 +145,11 @@ contains
implicit none
class(psb_l_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function l_vect_get_dupl
subroutine l_vect_set_dupl(x,val)
@ -141,13 +157,92 @@ contains
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine l_vect_set_dupl
function l_vect_get_state(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function l_vect_get_state
function l_vect_is_null(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function l_vect_is_null
function l_vect_is_bld(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function l_vect_is_bld
function l_vect_is_upd(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function l_vect_is_upd
function l_vect_is_asb(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function l_vect_is_asb
subroutine l_vect_set_state(n,x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine l_vect_set_state
subroutine l_vect_set_null(x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine l_vect_set_null
subroutine l_vect_set_bld(x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine l_vect_set_bld
subroutine l_vect_set_upd(x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine l_vect_set_upd
subroutine l_vect_set_asb(x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine l_vect_set_asb
function l_vect_get_nrmv(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
@ -237,12 +332,21 @@ contains
end if
end subroutine l_vect_clone
subroutine l_vect_bld_x(x,invect,mold)
subroutine l_vect_bld_x(x,invect,mold,scratch)
integer(psb_lpk_), intent(in) :: invect(:)
class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@ -253,17 +357,25 @@ contains
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine l_vect_bld_x
subroutine l_vect_bld_mn(x,n,mold)
subroutine l_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@ -274,17 +386,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine l_vect_bld_mn
subroutine l_vect_bld_en(x,n,mold)
subroutine l_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@ -294,7 +414,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine l_vect_bld_en
@ -396,8 +516,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine l_vect_all
subroutine l_vect_reinit(x, info)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine l_vect_reinit
subroutine l_vect_reall(n, x, info)
implicit none
@ -422,16 +553,17 @@ contains
end subroutine l_vect_zero
subroutine l_vect_asb(n, x, info)
subroutine l_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine l_vect_asb
@ -486,11 +618,11 @@ contains
end subroutine l_vect_free
subroutine l_vect_ins_a(n,irl,val,x,info)
subroutine l_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -503,15 +635,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine l_vect_ins_a
subroutine l_vect_ins_v(n,irl,val,x,info)
subroutine l_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_l_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -524,7 +656,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine l_vect_ins_v

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

@ -65,6 +65,18 @@ module psb_s_base_vect_mod
real(psb_spk_), allocatable :: v(:)
real(psb_spk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@ -88,6 +100,21 @@ module psb_s_base_vect_mod
procedure, pass(x) :: asb_e => s_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => s_base_free
procedure, pass(x) :: reinit => s_base_reinit
procedure, pass(x) :: set_ncfs => s_base_set_ncfs
procedure, pass(x) :: get_ncfs => s_base_get_ncfs
procedure, pass(x) :: set_dupl => s_base_set_dupl
procedure, pass(x) :: get_dupl => s_base_get_dupl
procedure, pass(x) :: set_state => s_base_set_state
procedure, pass(x) :: set_null => s_base_set_null
procedure, pass(x) :: set_bld => s_base_set_bld
procedure, pass(x) :: set_upd => s_base_set_upd
procedure, pass(x) :: set_asb => s_base_set_asb
procedure, pass(x) :: get_state => s_base_get_state
procedure, pass(x) :: is_null => s_base_is_null
procedure, pass(x) :: is_bld => s_base_is_bld
procedure, pass(x) :: is_upd => s_base_is_upd
procedure, pass(x) :: is_asb => s_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -218,8 +245,6 @@ module psb_s_base_vect_mod
procedure, pass(x) :: minquotient_a2 => s_base_minquotient_a2
generic, public :: minquotient => minquotient_v, minquotient_a2
end type psb_s_base_vect_type
public :: psb_s_base_vect
@ -270,14 +295,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine s_base_bld_x(x,this)
subroutine s_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
real(psb_spk_), intent(in) :: this(:)
class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -302,15 +335,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine s_base_bld_mn(x,n)
subroutine s_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine s_base_bld_mn
@ -319,15 +360,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine s_base_bld_en(x,n)
subroutine s_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine s_base_bld_en
@ -347,9 +396,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine s_base_all
subroutine s_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_s_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = szero
call x%set_host()
call x%set_upd()
end if
end subroutine s_base_reinit
!> Function base_mold:
!! \memberof psb_s_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@ -395,55 +464,116 @@ contains
!! \param info return code
!!
!
subroutine s_base_ins_a(n,irl,val,dupl,x,info)
subroutine s_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
call x%set_ncfs(k)
else if (x%is_upd()) then
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@ -453,11 +583,11 @@ contains
end subroutine s_base_ins_a
subroutine s_base_ins_v(n,irl,val,dupl,x,info)
subroutine s_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -470,7 +600,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@ -514,19 +644,70 @@ contains
!!
!
subroutine s_base_asb_m(n, x, info)
subroutine s_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_spk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine s_base_asb_m
@ -544,19 +725,70 @@ contains
!!
!
subroutine s_base_asb_e(n, x, info)
subroutine s_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_spk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine s_base_asb_e
@ -579,9 +811,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine s_base_free
@ -644,7 +877,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine s_base_free_comid
function s_base_get_ncfs(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function s_base_get_ncfs
function s_base_get_dupl(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function s_base_get_dupl
function s_base_get_state(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function s_base_get_state
function s_base_is_null(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function s_base_is_null
function s_base_is_bld(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function s_base_is_bld
function s_base_is_upd(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function s_base_is_upd
function s_base_is_asb(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function s_base_is_asb
subroutine s_base_set_ncfs(n,x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine s_base_set_ncfs
subroutine s_base_set_dupl(n,x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine s_base_set_dupl
subroutine s_base_set_state(n,x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine s_base_set_state
subroutine s_base_set_null(x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine s_base_set_null
subroutine s_base_set_bld(x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine s_base_set_bld
subroutine s_base_set_upd(x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine s_base_set_upd
subroutine s_base_set_asb(x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine s_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just

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

@ -56,14 +56,26 @@ module psb_s_vect_mod
procedure, pass(x) :: get_fmt => s_vect_get_fmt
procedure, pass(x) :: is_remote_build => s_vect_is_remote_build
procedure, pass(x) :: set_remote_build => s_vect_set_remote_build
procedure, pass(x) :: get_dupl => s_vect_get_dupl
procedure, pass(x) :: set_dupl => s_vect_set_dupl
procedure, pass(x) :: get_nrmv => s_vect_get_nrmv
procedure, pass(x) :: set_nrmv => s_vect_set_nrmv
procedure, pass(x) :: all => s_vect_all
procedure, pass(x) :: reall => s_vect_reall
procedure, pass(x) :: zero => s_vect_zero
procedure, pass(x) :: asb => s_vect_asb
procedure, pass(x) :: set_dupl => s_vect_set_dupl
procedure, pass(x) :: get_dupl => s_vect_get_dupl
procedure, pass(x) :: set_state => s_vect_set_state
procedure, pass(x) :: set_null => s_vect_set_null
procedure, pass(x) :: set_bld => s_vect_set_bld
procedure, pass(x) :: set_upd => s_vect_set_upd
procedure, pass(x) :: set_asb => s_vect_set_asb
procedure, pass(x) :: get_state => s_vect_get_state
procedure, pass(x) :: is_null => s_vect_is_null
procedure, pass(x) :: is_bld => s_vect_is_bld
procedure, pass(x) :: is_upd => s_vect_is_upd
procedure, pass(x) :: is_asb => s_vect_is_asb
procedure, pass(x) :: reinit => s_vect_reinit
procedure, pass(x) :: gthab => s_vect_gthab
procedure, pass(x) :: gthzv => s_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -194,7 +206,11 @@ contains
implicit none
class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function s_vect_get_dupl
subroutine s_vect_set_dupl(x,val)
@ -202,13 +218,92 @@ contains
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine s_vect_set_dupl
function s_vect_get_state(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function s_vect_get_state
function s_vect_is_null(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function s_vect_is_null
function s_vect_is_bld(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function s_vect_is_bld
function s_vect_is_upd(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function s_vect_is_upd
function s_vect_is_asb(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function s_vect_is_asb
subroutine s_vect_set_state(n,x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine s_vect_set_state
subroutine s_vect_set_null(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine s_vect_set_null
subroutine s_vect_set_bld(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine s_vect_set_bld
subroutine s_vect_set_upd(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine s_vect_set_upd
subroutine s_vect_set_asb(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine s_vect_set_asb
function s_vect_get_nrmv(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
@ -298,12 +393,21 @@ contains
end if
end subroutine s_vect_clone
subroutine s_vect_bld_x(x,invect,mold)
subroutine s_vect_bld_x(x,invect,mold,scratch)
real(psb_spk_), intent(in) :: invect(:)
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@ -314,17 +418,25 @@ contains
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine s_vect_bld_x
subroutine s_vect_bld_mn(x,n,mold)
subroutine s_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@ -335,17 +447,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine s_vect_bld_mn
subroutine s_vect_bld_en(x,n,mold)
subroutine s_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@ -355,7 +475,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine s_vect_bld_en
@ -457,8 +577,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine s_vect_all
subroutine s_vect_reinit(x, info)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine s_vect_reinit
subroutine s_vect_reall(n, x, info)
implicit none
@ -483,16 +614,17 @@ contains
end subroutine s_vect_zero
subroutine s_vect_asb(n, x, info)
subroutine s_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine s_vect_asb
@ -547,11 +679,11 @@ contains
end subroutine s_vect_free
subroutine s_vect_ins_a(n,irl,val,x,info)
subroutine s_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -564,15 +696,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine s_vect_ins_a
subroutine s_vect_ins_v(n,irl,val,x,info)
subroutine s_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -585,7 +717,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine s_vect_ins_v

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

@ -65,6 +65,18 @@ module psb_z_base_vect_mod
complex(psb_dpk_), allocatable :: v(:)
complex(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@ -88,6 +100,21 @@ module psb_z_base_vect_mod
procedure, pass(x) :: asb_e => z_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => z_base_free
procedure, pass(x) :: reinit => z_base_reinit
procedure, pass(x) :: set_ncfs => z_base_set_ncfs
procedure, pass(x) :: get_ncfs => z_base_get_ncfs
procedure, pass(x) :: set_dupl => z_base_set_dupl
procedure, pass(x) :: get_dupl => z_base_get_dupl
procedure, pass(x) :: set_state => z_base_set_state
procedure, pass(x) :: set_null => z_base_set_null
procedure, pass(x) :: set_bld => z_base_set_bld
procedure, pass(x) :: set_upd => z_base_set_upd
procedure, pass(x) :: set_asb => z_base_set_asb
procedure, pass(x) :: get_state => z_base_get_state
procedure, pass(x) :: is_null => z_base_is_null
procedure, pass(x) :: is_bld => z_base_is_bld
procedure, pass(x) :: is_upd => z_base_is_upd
procedure, pass(x) :: is_asb => z_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@ -211,8 +238,6 @@ module psb_z_base_vect_mod
generic, public :: addconst => addconst_a2,addconst_v2
end type psb_z_base_vect_type
public :: psb_z_base_vect
@ -263,14 +288,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine z_base_bld_x(x,this)
subroutine z_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -295,15 +328,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine z_base_bld_mn(x,n)
subroutine z_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine z_base_bld_mn
@ -312,15 +353,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine z_base_bld_en(x,n)
subroutine z_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine z_base_bld_en
@ -340,9 +389,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine z_base_all
subroutine z_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_z_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = zzero
call x%set_host()
call x%set_upd()
end if
end subroutine z_base_reinit
!> Function base_mold:
!! \memberof psb_z_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@ -388,55 +457,116 @@ contains
!! \param info return code
!!
!
subroutine z_base_ins_a(n,irl,val,dupl,x,info)
subroutine z_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
call x%set_ncfs(k)
else if (x%is_upd()) then
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@ -446,11 +576,11 @@ contains
end subroutine z_base_ins_a
subroutine z_base_ins_v(n,irl,val,dupl,x,info)
subroutine z_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -463,7 +593,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@ -507,19 +637,70 @@ contains
!!
!
subroutine z_base_asb_m(n, x, info)
subroutine z_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_dpk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine z_base_asb_m
@ -537,19 +718,70 @@ contains
!!
!
subroutine z_base_asb_e(n, x, info)
subroutine z_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_dpk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine z_base_asb_e
@ -572,9 +804,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine z_base_free
@ -637,7 +870,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine z_base_free_comid
function z_base_get_ncfs(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function z_base_get_ncfs
function z_base_get_dupl(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function z_base_get_dupl
function z_base_get_state(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function z_base_get_state
function z_base_is_null(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function z_base_is_null
function z_base_is_bld(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function z_base_is_bld
function z_base_is_upd(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function z_base_is_upd
function z_base_is_asb(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function z_base_is_asb
subroutine z_base_set_ncfs(n,x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine z_base_set_ncfs
subroutine z_base_set_dupl(n,x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine z_base_set_dupl
subroutine z_base_set_state(n,x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine z_base_set_state
subroutine z_base_set_null(x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine z_base_set_null
subroutine z_base_set_bld(x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine z_base_set_bld
subroutine z_base_set_upd(x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine z_base_set_upd
subroutine z_base_set_asb(x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine z_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just

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

@ -56,14 +56,26 @@ module psb_z_vect_mod
procedure, pass(x) :: get_fmt => z_vect_get_fmt
procedure, pass(x) :: is_remote_build => z_vect_is_remote_build
procedure, pass(x) :: set_remote_build => z_vect_set_remote_build
procedure, pass(x) :: get_dupl => z_vect_get_dupl
procedure, pass(x) :: set_dupl => z_vect_set_dupl
procedure, pass(x) :: get_nrmv => z_vect_get_nrmv
procedure, pass(x) :: set_nrmv => z_vect_set_nrmv
procedure, pass(x) :: all => z_vect_all
procedure, pass(x) :: reall => z_vect_reall
procedure, pass(x) :: zero => z_vect_zero
procedure, pass(x) :: asb => z_vect_asb
procedure, pass(x) :: set_dupl => z_vect_set_dupl
procedure, pass(x) :: get_dupl => z_vect_get_dupl
procedure, pass(x) :: set_state => z_vect_set_state
procedure, pass(x) :: set_null => z_vect_set_null
procedure, pass(x) :: set_bld => z_vect_set_bld
procedure, pass(x) :: set_upd => z_vect_set_upd
procedure, pass(x) :: set_asb => z_vect_set_asb
procedure, pass(x) :: get_state => z_vect_get_state
procedure, pass(x) :: is_null => z_vect_is_null
procedure, pass(x) :: is_bld => z_vect_is_bld
procedure, pass(x) :: is_upd => z_vect_is_upd
procedure, pass(x) :: is_asb => z_vect_is_asb
procedure, pass(x) :: reinit => z_vect_reinit
procedure, pass(x) :: gthab => z_vect_gthab
procedure, pass(x) :: gthzv => z_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -187,7 +199,11 @@ contains
implicit none
class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function z_vect_get_dupl
subroutine z_vect_set_dupl(x,val)
@ -195,13 +211,92 @@ contains
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine z_vect_set_dupl
function z_vect_get_state(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function z_vect_get_state
function z_vect_is_null(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function z_vect_is_null
function z_vect_is_bld(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function z_vect_is_bld
function z_vect_is_upd(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function z_vect_is_upd
function z_vect_is_asb(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function z_vect_is_asb
subroutine z_vect_set_state(n,x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine z_vect_set_state
subroutine z_vect_set_null(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine z_vect_set_null
subroutine z_vect_set_bld(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine z_vect_set_bld
subroutine z_vect_set_upd(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine z_vect_set_upd
subroutine z_vect_set_asb(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine z_vect_set_asb
function z_vect_get_nrmv(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
@ -291,12 +386,21 @@ contains
end if
end subroutine z_vect_clone
subroutine z_vect_bld_x(x,invect,mold)
subroutine z_vect_bld_x(x,invect,mold,scratch)
complex(psb_dpk_), intent(in) :: invect(:)
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@ -307,17 +411,25 @@ contains
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine z_vect_bld_x
subroutine z_vect_bld_mn(x,n,mold)
subroutine z_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@ -328,17 +440,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine z_vect_bld_mn
subroutine z_vect_bld_en(x,n,mold)
subroutine z_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@ -348,7 +468,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine z_vect_bld_en
@ -450,8 +570,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine z_vect_all
subroutine z_vect_reinit(x, info)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine z_vect_reinit
subroutine z_vect_reall(n, x, info)
implicit none
@ -476,16 +607,17 @@ contains
end subroutine z_vect_zero
subroutine z_vect_asb(n, x, info)
subroutine z_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine z_vect_asb
@ -540,11 +672,11 @@ contains
end subroutine z_vect_free
subroutine z_vect_ins_a(n,irl,val,x,info)
subroutine z_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -557,15 +689,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine z_vect_ins_a
subroutine z_vect_ins_v(n,irl,val,x,info)
subroutine z_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -578,7 +710,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine z_vect_ins_v

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

@ -70,7 +70,7 @@ Module psb_c_tools_mod
interface psb_geasb
subroutine psb_casb_vect(x, desc_a, info,mold, scratch)
subroutine psb_casb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@ -78,6 +78,7 @@ Module psb_c_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_casb_vect
subroutine psb_casb_vect_r2(x, desc_a, info,mold, scratch)
import
@ -250,13 +251,14 @@ Module psb_c_tools_mod
end interface
interface psb_spasb
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
import
implicit none
type(psb_cspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_c_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and

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

@ -257,11 +257,11 @@ Module psb_d_tools_mod
type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dspasb
end interface

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

@ -69,7 +69,7 @@ Module psb_i_tools_mod
interface psb_geasb
subroutine psb_iasb_vect(x, desc_a, info,mold, scratch)
subroutine psb_iasb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@ -77,6 +77,7 @@ Module psb_i_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_iasb_vect
subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch)
import

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

@ -69,7 +69,7 @@ Module psb_l_tools_mod
interface psb_geasb
subroutine psb_lasb_vect(x, desc_a, info,mold, scratch)
subroutine psb_lasb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@ -77,6 +77,7 @@ Module psb_l_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_lasb_vect
subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch)
import

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

@ -70,7 +70,7 @@ Module psb_s_tools_mod
interface psb_geasb
subroutine psb_sasb_vect(x, desc_a, info,mold, scratch)
subroutine psb_sasb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@ -78,6 +78,7 @@ Module psb_s_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_sasb_vect
subroutine psb_sasb_vect_r2(x, desc_a, info,mold, scratch)
import
@ -250,13 +251,14 @@ Module psb_s_tools_mod
end interface
interface psb_spasb
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
import
implicit none
type(psb_sspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and

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

@ -70,7 +70,7 @@ Module psb_z_tools_mod
interface psb_geasb
subroutine psb_zasb_vect(x, desc_a, info,mold, scratch)
subroutine psb_zasb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@ -78,6 +78,7 @@ Module psb_z_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_zasb_vect
subroutine psb_zasb_vect_r2(x, desc_a, info,mold, scratch)
import
@ -250,13 +251,14 @@ Module psb_z_tools_mod
end interface
interface psb_spasb
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
import
implicit none
type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_z_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and

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

@ -109,12 +109,10 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then

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

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

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

@ -57,7 +57,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -198,7 +198,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@ -261,7 +261,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -368,7 +368,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then

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

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

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

@ -109,13 +109,10 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
!!$ else
!!$ dupl_ = psb_dupl_def_
end if
!!$ call x%set_dupl(dupl_)
call x%set_bld()
if (present(dupl)) then
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then

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

@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false.
!
subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
subroutine psb_dasb_vect(x, desc_a, info, mold, scratch, dupl)
use psb_base_mod, psb_protect_name => psb_dasb_vect
implicit none
@ -69,7 +69,6 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
!logical, parameter :: try_newins = .true.
info = psb_success_
name = 'psb_dgeasb_v'
@ -82,7 +81,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
@ -95,32 +94,30 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (try_newins) then
!!$ if (present(dupl)) then
!!$ call x%set_dupl(dupl)
!!$ end if
dupl_ = x%get_dupl()
dupl_ = x%get_dupl()
if (try_newins) then
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
call x%bld(ncol,mold=mold,scratch=scratch_)
else
if (x%is_bld().and.present(dupl)) then
call x%set_dupl(dupl)
call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
real(psb_dpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
@ -129,8 +126,8 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info)
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
@ -143,14 +140,12 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
else
dupl_ = x%get_dupl()
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
if (x%is_bld().and.present(dupl)) then
!!$ call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
@ -169,7 +164,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
end block
end if
call x%asb(ncol,info)
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
@ -182,6 +177,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if
call psb_erractionrestore(err_act)
return
@ -250,7 +246,7 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info)
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)

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

@ -57,7 +57,7 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@ -198,7 +198,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me

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

@ -138,11 +138,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
if (.not.a%is_bld()) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
end if
if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)

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

@ -109,12 +109,10 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then

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

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

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

@ -57,7 +57,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -198,7 +198,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@ -261,7 +261,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -368,7 +368,7 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then

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

@ -109,12 +109,10 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then

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

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

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

@ -57,7 +57,7 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -198,7 +198,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@ -261,7 +261,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -368,7 +368,7 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then

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

@ -109,12 +109,10 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then

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

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

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

@ -57,7 +57,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -198,7 +198,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@ -261,7 +261,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -368,7 +368,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then

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

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

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

@ -109,12 +109,10 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then

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

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

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

@ -57,7 +57,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@ -127,7 +127,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -198,7 +198,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@ -261,7 +261,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@ -368,7 +368,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then

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

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

48
cuda/psb_c_cuda_vect_mod.F90
Unescape Escape View File

@ -560,12 +560,20 @@ contains
end subroutine c_cuda_sctb_buf
subroutine c_cuda_bld_x(x,this)
subroutine c_cuda_bld_x(x,this,scratch)
use psb_base_mod
complex(psb_spk_), intent(in) :: this(:)
class(psb_c_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@ -578,11 +586,19 @@ contains
end subroutine c_cuda_bld_x
subroutine c_cuda_bld_mn(x,n)
subroutine c_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'c_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -679,26 +695,34 @@ contains
call x%set_scal(czero)
end subroutine c_cuda_zero
subroutine c_cuda_asb_m(n, x, info)
subroutine c_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_c_base_vect_type%asb(n,info)
call x%psb_c_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_c_base_vect_type%asb(n,info)
call x%psb_c_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine c_cuda_vect_finalize
subroutine c_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine c_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if
if (info /= 0) then
@ -1295,11 +1319,11 @@ contains
end subroutine c_cuda_ins_v
subroutine c_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine c_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_c_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_c_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine c_cuda_ins_a

40
cuda/psb_d_cuda_vect_mod.F90
Unescape Escape View File

@ -560,12 +560,20 @@ contains
end subroutine d_cuda_sctb_buf
subroutine d_cuda_bld_x(x,this)
subroutine d_cuda_bld_x(x,this,scratch)
use psb_base_mod
real(psb_dpk_), intent(in) :: this(:)
class(psb_d_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@ -578,11 +586,19 @@ contains
end subroutine d_cuda_bld_x
subroutine d_cuda_bld_mn(x,n)
subroutine d_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'d_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -679,26 +695,34 @@ contains
call x%set_scal(dzero)
end subroutine d_cuda_zero
subroutine d_cuda_asb_m(n, x, info)
subroutine d_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_d_base_vect_type%asb(n,info)
call x%psb_d_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_d_base_vect_type%asb(n,info)
call x%psb_d_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -1256,7 +1280,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -1299,7 +1323,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info

48
cuda/psb_i_cuda_vect_mod.F90
Unescape Escape View File

@ -542,12 +542,20 @@ contains
end subroutine i_cuda_sctb_buf
subroutine i_cuda_bld_x(x,this)
subroutine i_cuda_bld_x(x,this,scratch)
use psb_base_mod
integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@ -560,11 +568,19 @@ contains
end subroutine i_cuda_bld_x
subroutine i_cuda_bld_mn(x,n)
subroutine i_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'i_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -661,26 +677,34 @@ contains
call x%set_scal(izero)
end subroutine i_cuda_zero
subroutine i_cuda_asb_m(n, x, info)
subroutine i_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_i_base_vect_type%asb(n,info)
call x%psb_i_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_i_base_vect_type%asb(n,info)
call x%psb_i_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -814,11 +838,11 @@ contains
call x%free(info)
end subroutine i_cuda_vect_finalize
subroutine i_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine i_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -847,7 +871,7 @@ contains
if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if
if (info /= 0) then
@ -857,11 +881,11 @@ contains
end subroutine i_cuda_ins_v
subroutine i_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine i_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -870,7 +894,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_i_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_i_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine i_cuda_ins_a

48
cuda/psb_s_cuda_vect_mod.F90
Unescape Escape View File

@ -560,12 +560,20 @@ contains
end subroutine s_cuda_sctb_buf
subroutine s_cuda_bld_x(x,this)
subroutine s_cuda_bld_x(x,this,scratch)
use psb_base_mod
real(psb_spk_), intent(in) :: this(:)
class(psb_s_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@ -578,11 +586,19 @@ contains
end subroutine s_cuda_bld_x
subroutine s_cuda_bld_mn(x,n)
subroutine s_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'s_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -679,26 +695,34 @@ contains
call x%set_scal(szero)
end subroutine s_cuda_zero
subroutine s_cuda_asb_m(n, x, info)
subroutine s_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_s_base_vect_type%asb(n,info)
call x%psb_s_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_s_base_vect_type%asb(n,info)
call x%psb_s_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine s_cuda_vect_finalize
subroutine s_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine s_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if
if (info /= 0) then
@ -1295,11 +1319,11 @@ contains
end subroutine s_cuda_ins_v
subroutine s_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine s_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_s_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_s_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine s_cuda_ins_a

48
cuda/psb_z_cuda_vect_mod.F90
Unescape Escape View File

@ -560,12 +560,20 @@ contains
end subroutine z_cuda_sctb_buf
subroutine z_cuda_bld_x(x,this)
subroutine z_cuda_bld_x(x,this,scratch)
use psb_base_mod
complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@ -578,11 +586,19 @@ contains
end subroutine z_cuda_bld_x
subroutine z_cuda_bld_mn(x,n)
subroutine z_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'z_cuda_bld_n',i_err=(/n,n,n,n,n/))
@ -679,26 +695,34 @@ contains
call x%set_scal(zzero)
end subroutine z_cuda_zero
subroutine z_cuda_asb_m(n, x, info)
subroutine z_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_z_base_vect_type%asb(n,info)
call x%psb_z_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_z_base_vect_type%asb(n,info)
call x%psb_z_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine z_cuda_vect_finalize
subroutine z_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine z_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if
if (info /= 0) then
@ -1295,11 +1319,11 @@ contains
end subroutine z_cuda_ins_v
subroutine z_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine z_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_z_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_z_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine z_cuda_ins_a

47
openacc/psb_c_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_d_oacc_vect_mod.F90
Unescape Escape View File

@ -620,11 +620,11 @@ contains
end subroutine inner_gth
end subroutine d_oacc_gthzv_x
subroutine d_oacc_ins_v(n, irl, val, dupl, x,maxr, info)
subroutine d_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@ -661,7 +661,7 @@ contains
type is (psb_d_vect_oacc)
if (vval%is_dev()) call vval%sync()
end select
call x%ins(n, irl%v, val%v, dupl,maxr, info)
call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if
if (info /= 0) then
@ -671,11 +671,11 @@ contains
end subroutine d_oacc_ins_v
subroutine d_oacc_ins_a(n, irl, val, dupl, x,maxr, info)
subroutine d_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@ -684,19 +684,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_d_base_vect_type%ins(n, irl, val, dupl,maxr, info)
call x%psb_d_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine d_oacc_ins_a
subroutine d_oacc_bld_mn(x, n)
subroutine d_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@ -709,13 +716,21 @@ contains
end subroutine d_oacc_bld_mn
subroutine d_oacc_bld_x(x, this)
subroutine d_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
real(psb_dpk_), intent(in) :: this(:)
class(psb_d_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@ -730,27 +745,35 @@ contains
end subroutine d_oacc_bld_x
subroutine d_oacc_asb_m(n, x, info)
subroutine d_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_d_base_vect_type%asb(n, info)
call x%psb_d_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_d_base_vect_type%asb(n, info)
call x%psb_d_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if

47
openacc/psb_i_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_l_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_s_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_z_oacc_vect_mod.F90
Unescape Escape View File

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

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

@ -406,11 +406,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@ -558,9 +558,9 @@ contains
t1 = psb_wtime()
if (info == psb_success_) then
if (present(amold)) then
call psb_spasb(a,desc_a,info,mold=amold)
call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_)
else
call psb_spasb(a,desc_a,info,afmt=afmt)
call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_)
end if
end if
call psb_barrier(ctxt)
@ -570,8 +570,8 @@ contains
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='asb rout.'

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

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

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

@ -406,11 +406,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@ -558,9 +558,9 @@ contains
t1 = psb_wtime()
if (info == psb_success_) then
if (present(amold)) then
call psb_spasb(a,desc_a,info,mold=amold)
call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_)
else
call psb_spasb(a,desc_a,info,afmt=afmt)
call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_)
end if
end if
call psb_barrier(ctxt)
@ -570,8 +570,8 @@ contains
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='asb rout.'

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

@ -435,11 +435,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz, &
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@ -606,9 +606,9 @@ contains
t1 = psb_wtime()
if (info == psb_success_) then
if (present(amold)) then
call psb_spasb(a,desc_a,info,mold=amold)
call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_)
else
call psb_spasb(a,desc_a,info,afmt=afmt)
call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_)
end if
end if
call psb_barrier(ctxt)
@ -618,8 +618,8 @@ contains
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='asb rout.'

Write Preview
Loading…
Cancel
Save