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 8 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 contains
procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt
end type psb_ctxt_type end type psb_ctxt_type
logical, parameter :: try_newins=.true.
contains contains
function psb_cmp_ctxt(ctxt1, ctxt2) result(res) function psb_cmp_ctxt(ctxt1, ctxt2) result(res)

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

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

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. !! in already existing entries.
!! The transitions among the states are detailed in !! The transitions among the states are detailed in
!! psb_T_vect_mod. !! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_ integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:) integer(psb_ipk_), allocatable :: iv(:)
contains contains
! !
@ -89,15 +89,17 @@ module psb_d_base_vect_mod
procedure, pass(x) :: mold => d_base_mold procedure, pass(x) :: mold => d_base_mold
! !
! Insert/set. Assembly and free. ! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
! in derived classes.
! !
procedure, pass(x) :: ins_a => d_base_ins_a procedure, pass(x) :: ins_a => d_base_ins_a
procedure, pass(x) :: ins_v => d_base_ins_v procedure, pass(x) :: ins_v => d_base_ins_v
generic, public :: ins => ins_a, ins_v generic, public :: ins => ins_a, ins_v
procedure, pass(x) :: zero => d_base_zero procedure, pass(x) :: zero => d_base_zero
procedure, pass(x) :: asb_m => d_base_asb_m procedure, pass(x) :: asb_m => d_base_asb_m
procedure, pass(x) :: asb_e => d_base_asb_e procedure, pass(x) :: asb_e => d_base_asb_e
generic, public :: asb => asb_m, asb_e generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => d_base_free procedure, pass(x) :: free => d_base_free
procedure, pass(x) :: reinit => d_base_reinit procedure, pass(x) :: reinit => d_base_reinit
procedure, pass(x) :: set_ncfs => d_base_set_ncfs procedure, pass(x) :: set_ncfs => d_base_set_ncfs
procedure, pass(x) :: get_ncfs => d_base_get_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 procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2
generic, public :: minquotient => minquotient_v, minquotient_a2 generic, public :: minquotient => minquotient_v, minquotient_a2
end type psb_d_base_vect_type end type psb_d_base_vect_type
public :: psb_d_base_vect public :: psb_d_base_vect
@ -253,7 +253,6 @@ module psb_d_base_vect_mod
module procedure constructor, size_const module procedure constructor, size_const
end interface psb_d_base_vect end interface psb_d_base_vect
logical, parameter :: try_newins=.true.
contains contains
! !
@ -296,14 +295,22 @@ contains
!! \brief Build method from an array !! \brief Build method from an array
!! \param x(:) input array to be copied !! \param x(:) input array to be copied
!! !!
subroutine d_base_bld_x(x,this) subroutine d_base_bld_x(x,this,scratch)
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
real(psb_dpk_), intent(in) :: this(:) real(psb_dpk_), intent(in) :: this(:)
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info) call psb_realloc(size(this),x%v,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -328,15 +335,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \param n size to be allocated.
!! !!
subroutine d_base_bld_mn(x,n) subroutine d_base_bld_mn(x,n,scratch)
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
call x%asb(n,info) call x%asb(n,info,scratch=scratch_)
end subroutine d_base_bld_mn end subroutine d_base_bld_mn
@ -345,15 +360,23 @@ contains
!! \brief Build method with size (uninitialized data) !! \brief Build method with size (uninitialized data)
!! \param n size to be allocated. !! \param n size to be allocated.
!! !!
subroutine d_base_bld_en(x,n) subroutine d_base_bld_en(x,n,scratch)
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
call x%asb(n,info) call x%asb(n,info,scratch=scratch_)
end subroutine d_base_bld_en end subroutine d_base_bld_en
@ -373,10 +396,10 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info) call psb_realloc(n,x%v,info)
#ifdef TRY_NEWINS if (try_newins) then
call psb_realloc(n,x%iv,info) call psb_realloc(n,x%iv,info)
call x%set_ncfs(0) call x%set_ncfs(0)
#endif end if
end subroutine d_base_all end subroutine d_base_all
@ -391,6 +414,7 @@ contains
call x%sync() call x%sync()
x%v(:) = dzero x%v(:) = dzero
call x%set_host() call x%set_host()
call x%set_upd()
end if end if
end subroutine d_base_reinit end subroutine d_base_reinit
@ -444,7 +468,7 @@ contains
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -453,56 +477,97 @@ contains
info = 0 info = 0
if (psb_errstatus_fatal()) return if (psb_errstatus_fatal()) return
#ifdef TRY_NEWINS
if (x%is_bld()) then if (try_newins) then
ncfs_ = x%get_ncfs() if (x%is_bld()) then
isz = ncfs_ + n ncfs_ = x%get_ncfs()
call psb_ensure_size(isz,x%v,info) isz = ncfs_ + n
call psb_ensure_size(isz,x%iv,info) call psb_ensure_size(isz,x%v,info)
k = ncfs_ call psb_ensure_size(isz,x%iv,info)
do i = 1, n k = ncfs_
!loop over all val's rows do i = 1, n
! row actual block row !loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then ! row actual block row
k = k + 1 if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me k = k + 1
! copy i-th row of block val in x ! this row belongs to me
x%v(k) = val(i) ! copy i-th row of block val in x
x%iv(k) = irl(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 end if
enddo else
call x%set_ncfs(k) info = psb_err_invalid_vect_state_
end if
else else
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_ info = psb_err_invalid_input_
else else
isz = size(x%v) isz = size(x%v)
select case(dupl_) select case(dupl)
case(psb_dupl_ovwrt_) case(psb_dupl_ovwrt_)
do i = 1, n do i = 1, n
!loop over all val's rows !loop over all val's rows
! row actual block row ! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block val in x ! copy i-th row of block val in x
x%v(irl(i)) = val(i) x%v(irl(i)) = val(i)
end if end if
enddo enddo
case(psb_dupl_add_) case(psb_dupl_add_)
do i = 1, n do i = 1, n
!loop over all val's rows !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 ! this row belongs to me
! copy i-th row of block val in x ! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i) x%v(irl(i)) = x%v(irl(i)) + val(i)
end if end if
enddo enddo
case default case default
info = 321 info = 321
! !$ call psb_errpush(info,name) ! !$ call psb_errpush(info,name)
@ -510,44 +575,6 @@ contains
end select end select
end if end if
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() call x%set_host()
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,'base_vect_ins') call psb_errpush(info,'base_vect_ins')
@ -560,7 +587,7 @@ contains
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,ncfs,xvsz logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_dpk_), allocatable :: vv(:) 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 (try_newins) then
if (x%is_bld()) then if (x%is_bld()) then
ncfs = x%get_ncfs() ncfs = x%get_ncfs()
@ -658,11 +693,14 @@ contains
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) & if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info) & call psb_realloc(n,x%v,info)
if (info /= 0) & if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if end if
else else
if (x%get_nrows() < n) & 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 psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_dpk_), allocatable :: vv(:) 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 (try_newins) then
if (info /= 0) & if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
@ -728,11 +774,14 @@ contains
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) & if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info) & call psb_realloc(n,x%v,info)
if (info /= 0) & if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if end if
else else
if (x%get_nrows() < n) & if (x%get_nrows() < n) &
@ -741,7 +790,6 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if end if
call x%sync() call x%sync()
end subroutine d_base_asb_e end subroutine d_base_asb_e
! !
@ -763,9 +811,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info) if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call & if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free') & psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine d_base_free end subroutine d_base_free
@ -828,7 +877,7 @@ contains
if (allocated(x%comid)) & if (allocated(x%comid)) &
& deallocate(x%comid,stat=info) & deallocate(x%comid,stat=info)
end subroutine d_base_free_comid end subroutine d_base_free_comid
function d_base_get_ncfs(x) result(res) function d_base_get_ncfs(x) result(res)
implicit none implicit none
class(psb_d_base_vect_type), intent(in) :: x class(psb_d_base_vect_type), intent(in) :: x
@ -926,7 +975,7 @@ contains
x%bldstate = psb_vect_asb_ x%bldstate = psb_vect_asb_
end subroutine d_base_set_asb end subroutine d_base_set_asb
! !
! The base version of SYNC & friends does nothing, it's just ! The base version of SYNC & friends does nothing, it's just
! a placeholder. ! 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 type psb_d_vect_type
class(psb_d_base_vect_type), allocatable :: v class(psb_d_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0 integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build = psb_matbld_noremote_ integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
real(psb_dpk_), allocatable :: rmtv(:) real(psb_dpk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:) integer(psb_lpk_), allocatable :: rmidx(:)
contains contains
@ -74,7 +75,7 @@ module psb_d_vect_mod
procedure, pass(x) :: is_upd => d_vect_is_upd procedure, pass(x) :: is_upd => d_vect_is_upd
procedure, pass(x) :: is_asb => d_vect_is_asb procedure, pass(x) :: is_asb => d_vect_is_asb
procedure, pass(x) :: reinit => d_vect_reinit procedure, pass(x) :: reinit => d_vect_reinit
procedure, pass(x) :: gthab => d_vect_gthab procedure, pass(x) :: gthab => d_vect_gthab
procedure, pass(x) :: gthzv => d_vect_gthzv procedure, pass(x) :: gthzv => d_vect_gthzv
generic, public :: gth => gthab, gthzv generic, public :: gth => gthab, gthzv
@ -303,7 +304,6 @@ contains
call x%set_state(psb_vect_asb_) call x%set_state(psb_vect_asb_)
end subroutine d_vect_set_asb end subroutine d_vect_set_asb
function d_vect_get_nrmv(x) result(res) function d_vect_get_nrmv(x) result(res)
implicit none implicit none
class(psb_d_vect_type), intent(in) :: x class(psb_d_vect_type), intent(in) :: x
@ -393,12 +393,21 @@ contains
end if end if
end subroutine d_vect_clone end subroutine d_vect_clone
subroutine d_vect_bld_x(x,invect,mold) subroutine d_vect_bld_x(x,invect,mold,scratch)
real(psb_dpk_), intent(in) :: invect(:) real(psb_dpk_), intent(in) :: invect(:)
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -409,17 +418,25 @@ contains
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine d_vect_bld_x end subroutine d_vect_bld_x
subroutine d_vect_bld_mn(x,n,mold) subroutine d_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld class(psb_d_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_ info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
@ -430,17 +447,25 @@ contains
else else
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine d_vect_bld_mn end subroutine d_vect_bld_mn
subroutine d_vect_bld_en(x,n,mold) subroutine d_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n integer(psb_epk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_ info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -450,7 +475,7 @@ contains
else else
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine d_vect_bld_en end subroutine d_vect_bld_en
@ -556,7 +581,6 @@ contains
end subroutine d_vect_all end subroutine d_vect_all
subroutine d_vect_reinit(x, info) subroutine d_vect_reinit(x, info)
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -565,7 +589,7 @@ contains
call x%set_upd() call x%set_upd()
end subroutine d_vect_reinit end subroutine d_vect_reinit
subroutine d_vect_reall(n, x, info) subroutine d_vect_reall(n, x, info)
implicit none implicit none
@ -590,16 +614,17 @@ contains
end subroutine d_vect_zero end subroutine d_vect_zero
subroutine d_vect_asb(n, x, info) subroutine d_vect_asb(n, x, info, scratch)
use psi_serial_mod use psi_serial_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then if (allocated(x%v)) then
call x%v%asb(n,info) call x%v%asb(n,info,scratch=scratch)
end if end if
end subroutine d_vect_asb end subroutine d_vect_asb
@ -658,7 +683,7 @@ contains
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n,maxr integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -679,7 +704,7 @@ contains
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n,maxr integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: irl
class(psb_d_vect_type), intent(inout) :: val class(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info

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

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

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

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

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

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

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

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

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

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

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_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: upd integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dspasb end subroutine psb_dspasb
end interface 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 interface psb_geasb
subroutine psb_iasb_vect(x, desc_a, info,mold, scratch) subroutine psb_iasb_vect(x, desc_a, info,mold, scratch,dupl)
import import
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -77,6 +77,7 @@ Module psb_i_tools_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_iasb_vect end subroutine psb_iasb_vect
subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch) subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch)
import import

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

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

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

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

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

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

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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

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

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

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

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

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

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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
if (present(dupl)) then
dupl_ = dupl
!!$ else
!!$ dupl_ = psb_dupl_def_
end if
!!$ call x%set_dupl(dupl_)
call x%set_bld() call x%set_bld()
if (present(dupl)) then
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

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

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

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 (desc_a%is_bld()) then
if (.not.a%is_bld()) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
end if
if (local_) then if (local_) then
info = psb_err_invalid_a_and_cd_state_ info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)

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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

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

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

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

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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

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

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

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

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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

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

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

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

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

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

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 else
bldmode_ = psb_matbld_noremote_ bldmode_ = psb_matbld_noremote_
end if end if
call x%set_bld()
if (present(dupl)) then if (present(dupl)) then
dupl_ = dupl call x%set_dupl(dupl)
else end if
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(izero) call x%set_nrmv(izero)
if (x%is_remote_build()) then if (x%is_remote_build()) then

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

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

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

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

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

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

48
cuda/psb_c_cuda_vect_mod.F90
Unescape Escape View File

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

40
cuda/psb_d_cuda_vect_mod.F90
Unescape Escape View File

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

48
cuda/psb_i_cuda_vect_mod.F90
Unescape Escape View File

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

48
cuda/psb_s_cuda_vect_mod.F90
Unescape Escape View File

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

48
cuda/psb_z_cuda_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_c_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_d_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_i_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_l_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_s_oacc_vect_mod.F90
Unescape Escape View File

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

47
openacc/psb_z_oacc_vect_mod.F90
Unescape Escape View File

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

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

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

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

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

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

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

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

Write Preview
Loading…
Cancel
Save