fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-06 22:55:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Working version with mods for building with dealii requests

Browse Source
This commit is contained in:
sfilippone
2025-11-06 14:06:47 +01:00
parent 98a6eba948
commit 0c84efb887
56 changed files with 3739 additions and 872 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_const_mod.F90
+1 -1
View File
@@ -332,7 +332,7 @@ module psb_const_mod
contains
procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt
end type psb_ctxt_type
logical, parameter :: try_newins=.true.
contains
function psb_cmp_ctxt(ctxt1, ctxt2) result(res)
base/modules/serial/psb_c_base_vect_mod.F90
+379 -49
View File
@@ -65,6 +65,18 @@ module psb_c_base_vect_mod
complex(psb_spk_), allocatable :: v(:)
complex(psb_spk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@@ -88,6 +100,21 @@ module psb_c_base_vect_mod
procedure, pass(x) :: asb_e => c_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => c_base_free
procedure, pass(x) :: reinit => c_base_reinit
procedure, pass(x) :: set_ncfs => c_base_set_ncfs
procedure, pass(x) :: get_ncfs => c_base_get_ncfs
procedure, pass(x) :: set_dupl => c_base_set_dupl
procedure, pass(x) :: get_dupl => c_base_get_dupl
procedure, pass(x) :: set_state => c_base_set_state
procedure, pass(x) :: set_null => c_base_set_null
procedure, pass(x) :: set_bld => c_base_set_bld
procedure, pass(x) :: set_upd => c_base_set_upd
procedure, pass(x) :: set_asb => c_base_set_asb
procedure, pass(x) :: get_state => c_base_get_state
procedure, pass(x) :: is_null => c_base_is_null
procedure, pass(x) :: is_bld => c_base_is_bld
procedure, pass(x) :: is_upd => c_base_is_upd
procedure, pass(x) :: is_asb => c_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -211,8 +238,6 @@ module psb_c_base_vect_mod
generic, public :: addconst => addconst_a2,addconst_v2
end type psb_c_base_vect_type
public :: psb_c_base_vect
@@ -263,14 +288,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine c_base_bld_x(x,this)
subroutine c_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
complex(psb_spk_), intent(in) :: this(:)
class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@@ -295,15 +328,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine c_base_bld_mn(x,n)
subroutine c_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine c_base_bld_mn
@@ -312,15 +353,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine c_base_bld_en(x,n)
subroutine c_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine c_base_bld_en
@@ -340,9 +389,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine c_base_all
subroutine c_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_c_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = czero
call x%set_host()
call x%set_upd()
end if
end subroutine c_base_reinit
!> Function base_mold:
!! \memberof psb_c_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@@ -388,55 +457,116 @@ contains
!! \param info return code
!!
!
subroutine c_base_ins_a(n,irl,val,dupl,x,info)
subroutine c_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
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_)
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
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
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@@ -446,11 +576,11 @@ contains
end subroutine c_base_ins_a
subroutine c_base_ins_v(n,irl,val,dupl,x,info)
subroutine c_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -463,7 +593,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@@ -507,19 +637,70 @@ contains
!!
!
subroutine c_base_asb_m(n, x, info)
subroutine c_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_spk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine c_base_asb_m
@@ -537,19 +718,70 @@ contains
!!
!
subroutine c_base_asb_e(n, x, info)
subroutine c_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_spk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine c_base_asb_e
@@ -572,9 +804,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine c_base_free
@@ -637,7 +870,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine c_base_free_comid
function c_base_get_ncfs(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function c_base_get_ncfs
function c_base_get_dupl(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function c_base_get_dupl
function c_base_get_state(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function c_base_get_state
function c_base_is_null(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function c_base_is_null
function c_base_is_bld(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function c_base_is_bld
function c_base_is_upd(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function c_base_is_upd
function c_base_is_asb(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function c_base_is_asb
subroutine c_base_set_ncfs(n,x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine c_base_set_ncfs
subroutine c_base_set_dupl(n,x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine c_base_set_dupl
subroutine c_base_set_state(n,x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine c_base_set_state
subroutine c_base_set_null(x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine c_base_set_null
subroutine c_base_set_bld(x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine c_base_set_bld
subroutine c_base_set_upd(x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine c_base_set_upd
subroutine c_base_set_asb(x)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine c_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just
base/modules/serial/psb_c_vect_mod.F90
+153 -21
View File
@@ -56,14 +56,26 @@ module psb_c_vect_mod
procedure, pass(x) :: get_fmt => c_vect_get_fmt
procedure, pass(x) :: is_remote_build => c_vect_is_remote_build
procedure, pass(x) :: set_remote_build => c_vect_set_remote_build
procedure, pass(x) :: get_dupl => c_vect_get_dupl
procedure, pass(x) :: set_dupl => c_vect_set_dupl
procedure, pass(x) :: get_nrmv => c_vect_get_nrmv
procedure, pass(x) :: set_nrmv => c_vect_set_nrmv
procedure, pass(x) :: all => c_vect_all
procedure, pass(x) :: reall => c_vect_reall
procedure, pass(x) :: zero => c_vect_zero
procedure, pass(x) :: asb => c_vect_asb
procedure, pass(x) :: set_dupl => c_vect_set_dupl
procedure, pass(x) :: get_dupl => c_vect_get_dupl
procedure, pass(x) :: set_state => c_vect_set_state
procedure, pass(x) :: set_null => c_vect_set_null
procedure, pass(x) :: set_bld => c_vect_set_bld
procedure, pass(x) :: set_upd => c_vect_set_upd
procedure, pass(x) :: set_asb => c_vect_set_asb
procedure, pass(x) :: get_state => c_vect_get_state
procedure, pass(x) :: is_null => c_vect_is_null
procedure, pass(x) :: is_bld => c_vect_is_bld
procedure, pass(x) :: is_upd => c_vect_is_upd
procedure, pass(x) :: is_asb => c_vect_is_asb
procedure, pass(x) :: reinit => c_vect_reinit
procedure, pass(x) :: gthab => c_vect_gthab
procedure, pass(x) :: gthzv => c_vect_gthzv
generic, public :: gth => gthab, gthzv
@@ -187,7 +199,11 @@ contains
implicit none
class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function c_vect_get_dupl
subroutine c_vect_set_dupl(x,val)
@@ -195,13 +211,92 @@ contains
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine c_vect_set_dupl
function c_vect_get_state(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function c_vect_get_state
function c_vect_is_null(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function c_vect_is_null
function c_vect_is_bld(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function c_vect_is_bld
function c_vect_is_upd(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function c_vect_is_upd
function c_vect_is_asb(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function c_vect_is_asb
subroutine c_vect_set_state(n,x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine c_vect_set_state
subroutine c_vect_set_null(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine c_vect_set_null
subroutine c_vect_set_bld(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine c_vect_set_bld
subroutine c_vect_set_upd(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine c_vect_set_upd
subroutine c_vect_set_asb(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine c_vect_set_asb
function c_vect_get_nrmv(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
@@ -291,12 +386,21 @@ contains
end if
end subroutine c_vect_clone
subroutine c_vect_bld_x(x,invect,mold)
subroutine c_vect_bld_x(x,invect,mold,scratch)
complex(psb_spk_), intent(in) :: invect(:)
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@@ -307,17 +411,25 @@ contains
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine c_vect_bld_x
subroutine c_vect_bld_mn(x,n,mold)
subroutine c_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@@ -328,17 +440,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine c_vect_bld_mn
subroutine c_vect_bld_en(x,n,mold)
subroutine c_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@@ -348,7 +468,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine c_vect_bld_en
@@ -450,8 +570,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine c_vect_all
subroutine c_vect_reinit(x, info)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine c_vect_reinit
subroutine c_vect_reall(n, x, info)
implicit none
@@ -476,16 +607,17 @@ contains
end subroutine c_vect_zero
subroutine c_vect_asb(n, x, info)
subroutine c_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine c_vect_asb
@@ -540,11 +672,11 @@ contains
end subroutine c_vect_free
subroutine c_vect_ins_a(n,irl,val,x,info)
subroutine c_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -557,15 +689,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine c_vect_ins_a
subroutine c_vect_ins_v(n,irl,val,x,info)
subroutine c_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -578,7 +710,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine c_vect_ins_v
base/modules/serial/psb_d_base_vect_mod.F90
+150 -101
View File
@@ -73,9 +73,9 @@ module psb_d_base_vect_mod
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
@@ -89,15 +89,17 @@ module psb_d_base_vect_mod
procedure, pass(x) :: mold => d_base_mold
!
! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
! in derived classes.
!
procedure, pass(x) :: ins_a => d_base_ins_a
procedure, pass(x) :: ins_v => d_base_ins_v
generic, public :: ins => ins_a, ins_v
procedure, pass(x) :: zero => d_base_zero
procedure, pass(x) :: asb_m => d_base_asb_m
procedure, pass(x) :: asb_e => d_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => d_base_free
procedure, pass(x) :: ins_a => d_base_ins_a
procedure, pass(x) :: ins_v => d_base_ins_v
generic, public :: ins => ins_a, ins_v
procedure, pass(x) :: zero => d_base_zero
procedure, pass(x) :: asb_m => d_base_asb_m
procedure, pass(x) :: asb_e => d_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => d_base_free
procedure, pass(x) :: reinit => d_base_reinit
procedure, pass(x) :: set_ncfs => d_base_set_ncfs
procedure, pass(x) :: get_ncfs => d_base_get_ncfs
@@ -243,8 +245,6 @@ module psb_d_base_vect_mod
procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2
generic, public :: minquotient => minquotient_v, minquotient_a2
end type psb_d_base_vect_type
public :: psb_d_base_vect
@@ -253,7 +253,6 @@ module psb_d_base_vect_mod
module procedure constructor, size_const
end interface psb_d_base_vect
logical, parameter :: try_newins=.true.
contains
!
@@ -296,14 +295,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine d_base_bld_x(x,this)
subroutine d_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
real(psb_dpk_), intent(in) :: this(:)
class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@@ -328,15 +335,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine d_base_bld_mn(x,n)
subroutine d_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine d_base_bld_mn
@@ -345,15 +360,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine d_base_bld_en(x,n)
subroutine d_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine d_base_bld_en
@@ -373,10 +396,10 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
#ifdef TRY_NEWINS
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
#endif
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine d_base_all
@@ -391,6 +414,7 @@ contains
call x%sync()
x%v(:) = dzero
call x%set_host()
call x%set_upd()
end if
end subroutine d_base_reinit
@@ -444,7 +468,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -453,56 +477,97 @@ contains
info = 0
if (psb_errstatus_fatal()) return
#ifdef TRY_NEWINS
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(k) = val(i)
x%iv(k) = irl(i)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
call x%set_ncfs(k)
else if (x%is_upd()) then
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
enddo
call x%set_ncfs(k)
else
info = psb_err_invalid_vect_state_
end if
else
dupl_ = x%get_dupl()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl_)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
@@ -510,44 +575,6 @@ contains
end select
end if
end if
#else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
#endif
call x%set_host()
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@@ -560,7 +587,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -617,17 +644,25 @@ contains
!!
!
subroutine d_base_asb_m(n, x, info)
subroutine d_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,ncfs,xvsz
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_dpk_), allocatable :: vv(:)
info = 0
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
@@ -658,11 +693,14 @@ contains
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
@@ -687,17 +725,25 @@ contains
!!
!
subroutine d_base_asb_e(n, x, info)
subroutine d_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
real(psb_dpk_), allocatable :: vv(:)
info = 0
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_dpk_), allocatable :: vv(:)
info = 0
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
@@ -728,11 +774,14 @@ contains
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
@@ -741,7 +790,6 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine d_base_asb_e
!
@@ -763,9 +811,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine d_base_free
@@ -828,7 +877,7 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine d_base_free_comid
function d_base_get_ncfs(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
@@ -926,7 +975,7 @@ contains
x%bldstate = psb_vect_asb_
end subroutine d_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just
! a placeholder.
base/modules/serial/psb_d_vect_mod.F90
+41 -16
View File
@@ -45,8 +45,9 @@ module psb_d_vect_mod
type psb_d_vect_type
class(psb_d_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build = psb_matbld_noremote_
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
real(psb_dpk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:)
contains
@@ -74,7 +75,7 @@ module psb_d_vect_mod
procedure, pass(x) :: is_upd => d_vect_is_upd
procedure, pass(x) :: is_asb => d_vect_is_asb
procedure, pass(x) :: reinit => d_vect_reinit
procedure, pass(x) :: gthab => d_vect_gthab
procedure, pass(x) :: gthzv => d_vect_gthzv
generic, public :: gth => gthab, gthzv
@@ -303,7 +304,6 @@ contains
call x%set_state(psb_vect_asb_)
end subroutine d_vect_set_asb
function d_vect_get_nrmv(x) result(res)
implicit none
class(psb_d_vect_type), intent(in) :: x
@@ -393,12 +393,21 @@ contains
end if
end subroutine d_vect_clone
subroutine d_vect_bld_x(x,invect,mold)
subroutine d_vect_bld_x(x,invect,mold,scratch)
real(psb_dpk_), intent(in) :: invect(:)
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@@ -409,17 +418,25 @@ contains
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine d_vect_bld_x
subroutine d_vect_bld_mn(x,n,mold)
subroutine d_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@@ -430,17 +447,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine d_vect_bld_mn
subroutine d_vect_bld_en(x,n,mold)
subroutine d_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@@ -450,7 +475,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine d_vect_bld_en
@@ -556,7 +581,6 @@ contains
end subroutine d_vect_all
subroutine d_vect_reinit(x, info)
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
@@ -565,7 +589,7 @@ contains
call x%set_upd()
end subroutine d_vect_reinit
subroutine d_vect_reall(n, x, info)
implicit none
@@ -590,16 +614,17 @@ contains
end subroutine d_vect_zero
subroutine d_vect_asb(n, x, info)
subroutine d_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine d_vect_asb
@@ -658,7 +683,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n,maxr
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -679,7 +704,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n,maxr
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
base/modules/serial/psb_i_base_vect_mod.F90
+379 -49
View File
@@ -63,6 +63,18 @@ module psb_i_base_vect_mod
integer(psb_ipk_), allocatable :: v(:)
integer(psb_ipk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@@ -86,6 +98,21 @@ module psb_i_base_vect_mod
procedure, pass(x) :: asb_e => i_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => i_base_free
procedure, pass(x) :: reinit => i_base_reinit
procedure, pass(x) :: set_ncfs => i_base_set_ncfs
procedure, pass(x) :: get_ncfs => i_base_get_ncfs
procedure, pass(x) :: set_dupl => i_base_set_dupl
procedure, pass(x) :: get_dupl => i_base_get_dupl
procedure, pass(x) :: set_state => i_base_set_state
procedure, pass(x) :: set_null => i_base_set_null
procedure, pass(x) :: set_bld => i_base_set_bld
procedure, pass(x) :: set_upd => i_base_set_upd
procedure, pass(x) :: set_asb => i_base_set_asb
procedure, pass(x) :: get_state => i_base_get_state
procedure, pass(x) :: is_null => i_base_is_null
procedure, pass(x) :: is_bld => i_base_is_bld
procedure, pass(x) :: is_upd => i_base_is_upd
procedure, pass(x) :: is_asb => i_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -144,8 +171,6 @@ module psb_i_base_vect_mod
end type psb_i_base_vect_type
public :: psb_i_base_vect
@@ -196,14 +221,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine i_base_bld_x(x,this)
subroutine i_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@@ -228,15 +261,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine i_base_bld_mn(x,n)
subroutine i_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine i_base_bld_mn
@@ -245,15 +286,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine i_base_bld_en(x,n)
subroutine i_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine i_base_bld_en
@@ -273,9 +322,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine i_base_all
subroutine i_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = izero
call x%set_host()
call x%set_upd()
end if
end subroutine i_base_reinit
!> Function base_mold:
!! \memberof psb_i_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@@ -321,55 +390,116 @@ contains
!! \param info return code
!!
!
subroutine i_base_ins_a(n,irl,val,dupl,x,info)
subroutine i_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
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_)
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
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
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@@ -379,11 +509,11 @@ contains
end subroutine i_base_ins_a
subroutine i_base_ins_v(n,irl,val,dupl,x,info)
subroutine i_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -396,7 +526,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@@ -440,19 +570,70 @@ contains
!!
!
subroutine i_base_asb_m(n, x, info)
subroutine i_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_ipk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine i_base_asb_m
@@ -470,19 +651,70 @@ contains
!!
!
subroutine i_base_asb_e(n, x, info)
subroutine i_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_ipk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine i_base_asb_e
@@ -505,9 +737,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine i_base_free
@@ -570,7 +803,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine i_base_free_comid
function i_base_get_ncfs(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function i_base_get_ncfs
function i_base_get_dupl(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function i_base_get_dupl
function i_base_get_state(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function i_base_get_state
function i_base_is_null(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function i_base_is_null
function i_base_is_bld(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function i_base_is_bld
function i_base_is_upd(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function i_base_is_upd
function i_base_is_asb(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function i_base_is_asb
subroutine i_base_set_ncfs(n,x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine i_base_set_ncfs
subroutine i_base_set_dupl(n,x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine i_base_set_dupl
subroutine i_base_set_state(n,x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine i_base_set_state
subroutine i_base_set_null(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine i_base_set_null
subroutine i_base_set_bld(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine i_base_set_bld
subroutine i_base_set_upd(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine i_base_set_upd
subroutine i_base_set_asb(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine i_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just
base/modules/serial/psb_i_vect_mod.F90
+153 -21
View File
@@ -55,14 +55,26 @@ module psb_i_vect_mod
procedure, pass(x) :: get_fmt => i_vect_get_fmt
procedure, pass(x) :: is_remote_build => i_vect_is_remote_build
procedure, pass(x) :: set_remote_build => i_vect_set_remote_build
procedure, pass(x) :: get_dupl => i_vect_get_dupl
procedure, pass(x) :: set_dupl => i_vect_set_dupl
procedure, pass(x) :: get_nrmv => i_vect_get_nrmv
procedure, pass(x) :: set_nrmv => i_vect_set_nrmv
procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: reall => i_vect_reall
procedure, pass(x) :: zero => i_vect_zero
procedure, pass(x) :: asb => i_vect_asb
procedure, pass(x) :: set_dupl => i_vect_set_dupl
procedure, pass(x) :: get_dupl => i_vect_get_dupl
procedure, pass(x) :: set_state => i_vect_set_state
procedure, pass(x) :: set_null => i_vect_set_null
procedure, pass(x) :: set_bld => i_vect_set_bld
procedure, pass(x) :: set_upd => i_vect_set_upd
procedure, pass(x) :: set_asb => i_vect_set_asb
procedure, pass(x) :: get_state => i_vect_get_state
procedure, pass(x) :: is_null => i_vect_is_null
procedure, pass(x) :: is_bld => i_vect_is_bld
procedure, pass(x) :: is_upd => i_vect_is_upd
procedure, pass(x) :: is_asb => i_vect_is_asb
procedure, pass(x) :: reinit => i_vect_reinit
procedure, pass(x) :: gthab => i_vect_gthab
procedure, pass(x) :: gthzv => i_vect_gthzv
generic, public :: gth => gthab, gthzv
@@ -132,7 +144,11 @@ contains
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function i_vect_get_dupl
subroutine i_vect_set_dupl(x,val)
@@ -140,13 +156,92 @@ contains
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine i_vect_set_dupl
function i_vect_get_state(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function i_vect_get_state
function i_vect_is_null(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function i_vect_is_null
function i_vect_is_bld(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function i_vect_is_bld
function i_vect_is_upd(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function i_vect_is_upd
function i_vect_is_asb(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function i_vect_is_asb
subroutine i_vect_set_state(n,x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine i_vect_set_state
subroutine i_vect_set_null(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine i_vect_set_null
subroutine i_vect_set_bld(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine i_vect_set_bld
subroutine i_vect_set_upd(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine i_vect_set_upd
subroutine i_vect_set_asb(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine i_vect_set_asb
function i_vect_get_nrmv(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
@@ -236,12 +331,21 @@ contains
end if
end subroutine i_vect_clone
subroutine i_vect_bld_x(x,invect,mold)
subroutine i_vect_bld_x(x,invect,mold,scratch)
integer(psb_ipk_), intent(in) :: invect(:)
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@@ -252,17 +356,25 @@ contains
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine i_vect_bld_x
subroutine i_vect_bld_mn(x,n,mold)
subroutine i_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@@ -273,17 +385,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine i_vect_bld_mn
subroutine i_vect_bld_en(x,n,mold)
subroutine i_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@@ -293,7 +413,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine i_vect_bld_en
@@ -395,8 +515,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine i_vect_all
subroutine i_vect_reinit(x, info)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine i_vect_reinit
subroutine i_vect_reall(n, x, info)
implicit none
@@ -421,16 +552,17 @@ contains
end subroutine i_vect_zero
subroutine i_vect_asb(n, x, info)
subroutine i_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine i_vect_asb
@@ -485,11 +617,11 @@ contains
end subroutine i_vect_free
subroutine i_vect_ins_a(n,irl,val,x,info)
subroutine i_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -502,15 +634,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine i_vect_ins_a
subroutine i_vect_ins_v(n,irl,val,x,info)
subroutine i_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_i_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -523,7 +655,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine i_vect_ins_v
base/modules/serial/psb_l_base_vect_mod.F90
+379 -49
View File
@@ -64,6 +64,18 @@ module psb_l_base_vect_mod
integer(psb_lpk_), allocatable :: v(:)
integer(psb_lpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@@ -87,6 +99,21 @@ module psb_l_base_vect_mod
procedure, pass(x) :: asb_e => l_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => l_base_free
procedure, pass(x) :: reinit => l_base_reinit
procedure, pass(x) :: set_ncfs => l_base_set_ncfs
procedure, pass(x) :: get_ncfs => l_base_get_ncfs
procedure, pass(x) :: set_dupl => l_base_set_dupl
procedure, pass(x) :: get_dupl => l_base_get_dupl
procedure, pass(x) :: set_state => l_base_set_state
procedure, pass(x) :: set_null => l_base_set_null
procedure, pass(x) :: set_bld => l_base_set_bld
procedure, pass(x) :: set_upd => l_base_set_upd
procedure, pass(x) :: set_asb => l_base_set_asb
procedure, pass(x) :: get_state => l_base_get_state
procedure, pass(x) :: is_null => l_base_is_null
procedure, pass(x) :: is_bld => l_base_is_bld
procedure, pass(x) :: is_upd => l_base_is_upd
procedure, pass(x) :: is_asb => l_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -145,8 +172,6 @@ module psb_l_base_vect_mod
end type psb_l_base_vect_type
public :: psb_l_base_vect
@@ -197,14 +222,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine l_base_bld_x(x,this)
subroutine l_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
integer(psb_lpk_), intent(in) :: this(:)
class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@@ -229,15 +262,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine l_base_bld_mn(x,n)
subroutine l_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine l_base_bld_mn
@@ -246,15 +287,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine l_base_bld_en(x,n)
subroutine l_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine l_base_bld_en
@@ -274,9 +323,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine l_base_all
subroutine l_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_l_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = lzero
call x%set_host()
call x%set_upd()
end if
end subroutine l_base_reinit
!> Function base_mold:
!! \memberof psb_l_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@@ -322,55 +391,116 @@ contains
!! \param info return code
!!
!
subroutine l_base_ins_a(n,irl,val,dupl,x,info)
subroutine l_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
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_)
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
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
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@@ -380,11 +510,11 @@ contains
end subroutine l_base_ins_a
subroutine l_base_ins_v(n,irl,val,dupl,x,info)
subroutine l_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_l_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -397,7 +527,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@@ -441,19 +571,70 @@ contains
!!
!
subroutine l_base_asb_m(n, x, info)
subroutine l_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_lpk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine l_base_asb_m
@@ -471,19 +652,70 @@ contains
!!
!
subroutine l_base_asb_e(n, x, info)
subroutine l_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_lpk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine l_base_asb_e
@@ -506,9 +738,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine l_base_free
@@ -571,7 +804,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine l_base_free_comid
function l_base_get_ncfs(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function l_base_get_ncfs
function l_base_get_dupl(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function l_base_get_dupl
function l_base_get_state(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function l_base_get_state
function l_base_is_null(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function l_base_is_null
function l_base_is_bld(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function l_base_is_bld
function l_base_is_upd(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function l_base_is_upd
function l_base_is_asb(x) result(res)
implicit none
class(psb_l_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function l_base_is_asb
subroutine l_base_set_ncfs(n,x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine l_base_set_ncfs
subroutine l_base_set_dupl(n,x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine l_base_set_dupl
subroutine l_base_set_state(n,x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine l_base_set_state
subroutine l_base_set_null(x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine l_base_set_null
subroutine l_base_set_bld(x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine l_base_set_bld
subroutine l_base_set_upd(x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine l_base_set_upd
subroutine l_base_set_asb(x)
implicit none
class(psb_l_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine l_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just
base/modules/serial/psb_l_vect_mod.F90
+153 -21
View File
@@ -56,14 +56,26 @@ module psb_l_vect_mod
procedure, pass(x) :: get_fmt => l_vect_get_fmt
procedure, pass(x) :: is_remote_build => l_vect_is_remote_build
procedure, pass(x) :: set_remote_build => l_vect_set_remote_build
procedure, pass(x) :: get_dupl => l_vect_get_dupl
procedure, pass(x) :: set_dupl => l_vect_set_dupl
procedure, pass(x) :: get_nrmv => l_vect_get_nrmv
procedure, pass(x) :: set_nrmv => l_vect_set_nrmv
procedure, pass(x) :: all => l_vect_all
procedure, pass(x) :: reall => l_vect_reall
procedure, pass(x) :: zero => l_vect_zero
procedure, pass(x) :: asb => l_vect_asb
procedure, pass(x) :: set_dupl => l_vect_set_dupl
procedure, pass(x) :: get_dupl => l_vect_get_dupl
procedure, pass(x) :: set_state => l_vect_set_state
procedure, pass(x) :: set_null => l_vect_set_null
procedure, pass(x) :: set_bld => l_vect_set_bld
procedure, pass(x) :: set_upd => l_vect_set_upd
procedure, pass(x) :: set_asb => l_vect_set_asb
procedure, pass(x) :: get_state => l_vect_get_state
procedure, pass(x) :: is_null => l_vect_is_null
procedure, pass(x) :: is_bld => l_vect_is_bld
procedure, pass(x) :: is_upd => l_vect_is_upd
procedure, pass(x) :: is_asb => l_vect_is_asb
procedure, pass(x) :: reinit => l_vect_reinit
procedure, pass(x) :: gthab => l_vect_gthab
procedure, pass(x) :: gthzv => l_vect_gthzv
generic, public :: gth => gthab, gthzv
@@ -133,7 +145,11 @@ contains
implicit none
class(psb_l_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function l_vect_get_dupl
subroutine l_vect_set_dupl(x,val)
@@ -141,13 +157,92 @@ contains
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine l_vect_set_dupl
function l_vect_get_state(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function l_vect_get_state
function l_vect_is_null(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function l_vect_is_null
function l_vect_is_bld(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function l_vect_is_bld
function l_vect_is_upd(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function l_vect_is_upd
function l_vect_is_asb(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function l_vect_is_asb
subroutine l_vect_set_state(n,x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine l_vect_set_state
subroutine l_vect_set_null(x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine l_vect_set_null
subroutine l_vect_set_bld(x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine l_vect_set_bld
subroutine l_vect_set_upd(x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine l_vect_set_upd
subroutine l_vect_set_asb(x)
implicit none
class(psb_l_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine l_vect_set_asb
function l_vect_get_nrmv(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
@@ -237,12 +332,21 @@ contains
end if
end subroutine l_vect_clone
subroutine l_vect_bld_x(x,invect,mold)
subroutine l_vect_bld_x(x,invect,mold,scratch)
integer(psb_lpk_), intent(in) :: invect(:)
class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@@ -253,17 +357,25 @@ contains
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine l_vect_bld_x
subroutine l_vect_bld_mn(x,n,mold)
subroutine l_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@@ -274,17 +386,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine l_vect_bld_mn
subroutine l_vect_bld_en(x,n,mold)
subroutine l_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@@ -294,7 +414,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine l_vect_bld_en
@@ -396,8 +516,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine l_vect_all
subroutine l_vect_reinit(x, info)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine l_vect_reinit
subroutine l_vect_reall(n, x, info)
implicit none
@@ -422,16 +553,17 @@ contains
end subroutine l_vect_zero
subroutine l_vect_asb(n, x, info)
subroutine l_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine l_vect_asb
@@ -486,11 +618,11 @@ contains
end subroutine l_vect_free
subroutine l_vect_ins_a(n,irl,val,x,info)
subroutine l_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -503,15 +635,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine l_vect_ins_a
subroutine l_vect_ins_v(n,irl,val,x,info)
subroutine l_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_l_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -524,7 +656,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine l_vect_ins_v
base/modules/serial/psb_s_base_vect_mod.F90
+379 -49
View File
@@ -65,6 +65,18 @@ module psb_s_base_vect_mod
real(psb_spk_), allocatable :: v(:)
real(psb_spk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@@ -88,6 +100,21 @@ module psb_s_base_vect_mod
procedure, pass(x) :: asb_e => s_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => s_base_free
procedure, pass(x) :: reinit => s_base_reinit
procedure, pass(x) :: set_ncfs => s_base_set_ncfs
procedure, pass(x) :: get_ncfs => s_base_get_ncfs
procedure, pass(x) :: set_dupl => s_base_set_dupl
procedure, pass(x) :: get_dupl => s_base_get_dupl
procedure, pass(x) :: set_state => s_base_set_state
procedure, pass(x) :: set_null => s_base_set_null
procedure, pass(x) :: set_bld => s_base_set_bld
procedure, pass(x) :: set_upd => s_base_set_upd
procedure, pass(x) :: set_asb => s_base_set_asb
procedure, pass(x) :: get_state => s_base_get_state
procedure, pass(x) :: is_null => s_base_is_null
procedure, pass(x) :: is_bld => s_base_is_bld
procedure, pass(x) :: is_upd => s_base_is_upd
procedure, pass(x) :: is_asb => s_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -218,8 +245,6 @@ module psb_s_base_vect_mod
procedure, pass(x) :: minquotient_a2 => s_base_minquotient_a2
generic, public :: minquotient => minquotient_v, minquotient_a2
end type psb_s_base_vect_type
public :: psb_s_base_vect
@@ -270,14 +295,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine s_base_bld_x(x,this)
subroutine s_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
real(psb_spk_), intent(in) :: this(:)
class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@@ -302,15 +335,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine s_base_bld_mn(x,n)
subroutine s_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine s_base_bld_mn
@@ -319,15 +360,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine s_base_bld_en(x,n)
subroutine s_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine s_base_bld_en
@@ -347,9 +396,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine s_base_all
subroutine s_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_s_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = szero
call x%set_host()
call x%set_upd()
end if
end subroutine s_base_reinit
!> Function base_mold:
!! \memberof psb_s_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@@ -395,55 +464,116 @@ contains
!! \param info return code
!!
!
subroutine s_base_ins_a(n,irl,val,dupl,x,info)
subroutine s_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
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_)
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
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
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@@ -453,11 +583,11 @@ contains
end subroutine s_base_ins_a
subroutine s_base_ins_v(n,irl,val,dupl,x,info)
subroutine s_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -470,7 +600,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@@ -514,19 +644,70 @@ contains
!!
!
subroutine s_base_asb_m(n, x, info)
subroutine s_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_spk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine s_base_asb_m
@@ -544,19 +725,70 @@ contains
!!
!
subroutine s_base_asb_e(n, x, info)
subroutine s_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_spk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine s_base_asb_e
@@ -579,9 +811,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine s_base_free
@@ -644,7 +877,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine s_base_free_comid
function s_base_get_ncfs(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function s_base_get_ncfs
function s_base_get_dupl(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function s_base_get_dupl
function s_base_get_state(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function s_base_get_state
function s_base_is_null(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function s_base_is_null
function s_base_is_bld(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function s_base_is_bld
function s_base_is_upd(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function s_base_is_upd
function s_base_is_asb(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function s_base_is_asb
subroutine s_base_set_ncfs(n,x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine s_base_set_ncfs
subroutine s_base_set_dupl(n,x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine s_base_set_dupl
subroutine s_base_set_state(n,x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine s_base_set_state
subroutine s_base_set_null(x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine s_base_set_null
subroutine s_base_set_bld(x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine s_base_set_bld
subroutine s_base_set_upd(x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine s_base_set_upd
subroutine s_base_set_asb(x)
implicit none
class(psb_s_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine s_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just
base/modules/serial/psb_s_vect_mod.F90
+153 -21
View File
@@ -56,14 +56,26 @@ module psb_s_vect_mod
procedure, pass(x) :: get_fmt => s_vect_get_fmt
procedure, pass(x) :: is_remote_build => s_vect_is_remote_build
procedure, pass(x) :: set_remote_build => s_vect_set_remote_build
procedure, pass(x) :: get_dupl => s_vect_get_dupl
procedure, pass(x) :: set_dupl => s_vect_set_dupl
procedure, pass(x) :: get_nrmv => s_vect_get_nrmv
procedure, pass(x) :: set_nrmv => s_vect_set_nrmv
procedure, pass(x) :: all => s_vect_all
procedure, pass(x) :: reall => s_vect_reall
procedure, pass(x) :: zero => s_vect_zero
procedure, pass(x) :: asb => s_vect_asb
procedure, pass(x) :: set_dupl => s_vect_set_dupl
procedure, pass(x) :: get_dupl => s_vect_get_dupl
procedure, pass(x) :: set_state => s_vect_set_state
procedure, pass(x) :: set_null => s_vect_set_null
procedure, pass(x) :: set_bld => s_vect_set_bld
procedure, pass(x) :: set_upd => s_vect_set_upd
procedure, pass(x) :: set_asb => s_vect_set_asb
procedure, pass(x) :: get_state => s_vect_get_state
procedure, pass(x) :: is_null => s_vect_is_null
procedure, pass(x) :: is_bld => s_vect_is_bld
procedure, pass(x) :: is_upd => s_vect_is_upd
procedure, pass(x) :: is_asb => s_vect_is_asb
procedure, pass(x) :: reinit => s_vect_reinit
procedure, pass(x) :: gthab => s_vect_gthab
procedure, pass(x) :: gthzv => s_vect_gthzv
generic, public :: gth => gthab, gthzv
@@ -194,7 +206,11 @@ contains
implicit none
class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function s_vect_get_dupl
subroutine s_vect_set_dupl(x,val)
@@ -202,13 +218,92 @@ contains
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine s_vect_set_dupl
function s_vect_get_state(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function s_vect_get_state
function s_vect_is_null(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function s_vect_is_null
function s_vect_is_bld(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function s_vect_is_bld
function s_vect_is_upd(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function s_vect_is_upd
function s_vect_is_asb(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function s_vect_is_asb
subroutine s_vect_set_state(n,x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine s_vect_set_state
subroutine s_vect_set_null(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine s_vect_set_null
subroutine s_vect_set_bld(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine s_vect_set_bld
subroutine s_vect_set_upd(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine s_vect_set_upd
subroutine s_vect_set_asb(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine s_vect_set_asb
function s_vect_get_nrmv(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
@@ -298,12 +393,21 @@ contains
end if
end subroutine s_vect_clone
subroutine s_vect_bld_x(x,invect,mold)
subroutine s_vect_bld_x(x,invect,mold,scratch)
real(psb_spk_), intent(in) :: invect(:)
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@@ -314,17 +418,25 @@ contains
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine s_vect_bld_x
subroutine s_vect_bld_mn(x,n,mold)
subroutine s_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@@ -335,17 +447,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine s_vect_bld_mn
subroutine s_vect_bld_en(x,n,mold)
subroutine s_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@@ -355,7 +475,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine s_vect_bld_en
@@ -457,8 +577,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine s_vect_all
subroutine s_vect_reinit(x, info)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine s_vect_reinit
subroutine s_vect_reall(n, x, info)
implicit none
@@ -483,16 +614,17 @@ contains
end subroutine s_vect_zero
subroutine s_vect_asb(n, x, info)
subroutine s_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine s_vect_asb
@@ -547,11 +679,11 @@ contains
end subroutine s_vect_free
subroutine s_vect_ins_a(n,irl,val,x,info)
subroutine s_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -564,15 +696,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine s_vect_ins_a
subroutine s_vect_ins_v(n,irl,val,x,info)
subroutine s_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -585,7 +717,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine s_vect_ins_v
base/modules/serial/psb_z_base_vect_mod.F90
+379 -49
View File
@@ -65,6 +65,18 @@ module psb_z_base_vect_mod
complex(psb_dpk_), allocatable :: v(:)
complex(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@@ -88,6 +100,21 @@ module psb_z_base_vect_mod
procedure, pass(x) :: asb_e => z_base_asb_e
generic, public :: asb => asb_m, asb_e
procedure, pass(x) :: free => z_base_free
procedure, pass(x) :: reinit => z_base_reinit
procedure, pass(x) :: set_ncfs => z_base_set_ncfs
procedure, pass(x) :: get_ncfs => z_base_get_ncfs
procedure, pass(x) :: set_dupl => z_base_set_dupl
procedure, pass(x) :: get_dupl => z_base_get_dupl
procedure, pass(x) :: set_state => z_base_set_state
procedure, pass(x) :: set_null => z_base_set_null
procedure, pass(x) :: set_bld => z_base_set_bld
procedure, pass(x) :: set_upd => z_base_set_upd
procedure, pass(x) :: set_asb => z_base_set_asb
procedure, pass(x) :: get_state => z_base_get_state
procedure, pass(x) :: is_null => z_base_is_null
procedure, pass(x) :: is_bld => z_base_is_bld
procedure, pass(x) :: is_upd => z_base_is_upd
procedure, pass(x) :: is_asb => z_base_is_asb
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -211,8 +238,6 @@ module psb_z_base_vect_mod
generic, public :: addconst => addconst_a2,addconst_v2
end type psb_z_base_vect_type
public :: psb_z_base_vect
@@ -263,14 +288,22 @@ contains
!! \brief Build method from an array
!! \param x(:) input array to be copied
!!
subroutine z_base_bld_x(x,this)
subroutine z_base_bld_x(x,this,scratch)
use psb_realloc_mod
implicit none
complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@@ -295,15 +328,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine z_base_bld_mn(x,n)
subroutine z_base_bld_mn(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine z_base_bld_mn
@@ -312,15 +353,23 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine z_base_bld_en(x,n)
subroutine z_base_bld_en(x,n,scratch)
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(n,x%v,info)
call x%asb(n,info)
call x%asb(n,info,scratch=scratch_)
end subroutine z_base_bld_en
@@ -340,9 +389,29 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine z_base_all
subroutine z_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_z_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = zzero
call x%set_host()
call x%set_upd()
end if
end subroutine z_base_reinit
!> Function base_mold:
!! \memberof psb_z_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@@ -388,55 +457,116 @@ contains
!! \param info return code
!!
!
subroutine z_base_ins_a(n,irl,val,dupl,x,info)
subroutine z_base_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_ensure_size(isz,x%v,info)
call psb_ensure_size(isz,x%iv,info)
k = ncfs_
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
k = k + 1
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
x%v(k) = val(i)
x%iv(k) = irl(i)
end if
enddo
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_)
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
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
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v)
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= isz)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
end if
call x%set_host()
if (info /= 0) then
@@ -446,11 +576,11 @@ contains
end subroutine z_base_ins_a
subroutine z_base_ins_v(n,irl,val,dupl,x,info)
subroutine z_base_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -463,7 +593,7 @@ contains
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
@@ -507,19 +637,70 @@ contains
!!
!
subroutine z_base_asb_m(n, x, info)
subroutine z_base_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_dpk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (x%is_bld()) then
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,ncfs
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine z_base_asb_m
@@ -537,19 +718,70 @@ contains
!!
!
subroutine z_base_asb_e(n, x, info)
subroutine z_base_asb_e(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_dpk_), allocatable :: vv(:)
info = 0
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (try_newins) then
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = vv(x%iv(i)) + x%v(i)
end do
case(psb_dupl_ovwrt_)
do i=1,x%get_ncfs()
vv(x%iv(i)) = x%v(i)
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
vv(x%iv(i)) = x%v(i)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.scratch_) then
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
else
info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb')
end if
else
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%sync()
end subroutine z_base_asb_e
@@ -572,9 +804,10 @@ contains
if (allocated(x%v)) deallocate(x%v, stat=info)
if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info)
if ((info == 0).and.allocated(x%comid)) call x%free_comid(info)
if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
call x%set_null()
end subroutine z_base_free
@@ -637,7 +870,104 @@ contains
if (allocated(x%comid)) &
& deallocate(x%comid,stat=info)
end subroutine z_base_free_comid
function z_base_get_ncfs(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function z_base_get_ncfs
function z_base_get_dupl(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function z_base_get_dupl
function z_base_get_state(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function z_base_get_state
function z_base_is_null(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function z_base_is_null
function z_base_is_bld(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function z_base_is_bld
function z_base_is_upd(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function z_base_is_upd
function z_base_is_asb(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function z_base_is_asb
subroutine z_base_set_ncfs(n,x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine z_base_set_ncfs
subroutine z_base_set_dupl(n,x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine z_base_set_dupl
subroutine z_base_set_state(n,x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine z_base_set_state
subroutine z_base_set_null(x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine z_base_set_null
subroutine z_base_set_bld(x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine z_base_set_bld
subroutine z_base_set_upd(x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine z_base_set_upd
subroutine z_base_set_asb(x)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine z_base_set_asb
!
! The base version of SYNC & friends does nothing, it's just
base/modules/serial/psb_z_vect_mod.F90
+153 -21
View File
@@ -56,14 +56,26 @@ module psb_z_vect_mod
procedure, pass(x) :: get_fmt => z_vect_get_fmt
procedure, pass(x) :: is_remote_build => z_vect_is_remote_build
procedure, pass(x) :: set_remote_build => z_vect_set_remote_build
procedure, pass(x) :: get_dupl => z_vect_get_dupl
procedure, pass(x) :: set_dupl => z_vect_set_dupl
procedure, pass(x) :: get_nrmv => z_vect_get_nrmv
procedure, pass(x) :: set_nrmv => z_vect_set_nrmv
procedure, pass(x) :: all => z_vect_all
procedure, pass(x) :: reall => z_vect_reall
procedure, pass(x) :: zero => z_vect_zero
procedure, pass(x) :: asb => z_vect_asb
procedure, pass(x) :: set_dupl => z_vect_set_dupl
procedure, pass(x) :: get_dupl => z_vect_get_dupl
procedure, pass(x) :: set_state => z_vect_set_state
procedure, pass(x) :: set_null => z_vect_set_null
procedure, pass(x) :: set_bld => z_vect_set_bld
procedure, pass(x) :: set_upd => z_vect_set_upd
procedure, pass(x) :: set_asb => z_vect_set_asb
procedure, pass(x) :: get_state => z_vect_get_state
procedure, pass(x) :: is_null => z_vect_is_null
procedure, pass(x) :: is_bld => z_vect_is_bld
procedure, pass(x) :: is_upd => z_vect_is_upd
procedure, pass(x) :: is_asb => z_vect_is_asb
procedure, pass(x) :: reinit => z_vect_reinit
procedure, pass(x) :: gthab => z_vect_gthab
procedure, pass(x) :: gthzv => z_vect_gthzv
generic, public :: gth => gthab, gthzv
@@ -187,7 +199,11 @@ contains
implicit none
class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function z_vect_get_dupl
subroutine z_vect_set_dupl(x,val)
@@ -195,13 +211,92 @@ contains
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
if (allocated(x%v)) then
if (present(val)) then
call x%v%set_dupl(val)
else
call x%v%set_dupl(psb_dupl_def_)
end if
end if
end subroutine z_vect_set_dupl
function z_vect_get_state(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%get_state()
else
res = psb_vect_null_
end if
end function z_vect_get_state
function z_vect_is_null(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_null_)
end function z_vect_is_null
function z_vect_is_bld(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_bld_)
end function z_vect_is_bld
function z_vect_is_upd(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_upd_)
end function z_vect_is_upd
function z_vect_is_asb(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%get_state() == psb_vect_asb_)
end function z_vect_is_asb
subroutine z_vect_set_state(n,x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
if (allocated(x%v)) then
call x%v%set_state(n)
end if
end subroutine z_vect_set_state
subroutine z_vect_set_null(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
call x%set_state(psb_vect_null_)
end subroutine z_vect_set_null
subroutine z_vect_set_bld(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
call x%set_state(psb_vect_bld_)
end subroutine z_vect_set_bld
subroutine z_vect_set_upd(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
call x%set_state(psb_vect_upd_)
end subroutine z_vect_set_upd
subroutine z_vect_set_asb(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
call x%set_state(psb_vect_asb_)
end subroutine z_vect_set_asb
function z_vect_get_nrmv(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
@@ -291,12 +386,21 @@ contains
end if
end subroutine z_vect_clone
subroutine z_vect_bld_x(x,invect,mold)
subroutine z_vect_bld_x(x,invect,mold,scratch)
complex(psb_dpk_), intent(in) :: invect(:)
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
@@ -307,17 +411,25 @@ contains
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(invect)
if (info == psb_success_) call x%v%bld(invect,scratch=scratch_)
end subroutine z_vect_bld_x
subroutine z_vect_bld_mn(x,n,mold)
subroutine z_vect_bld_mn(x,n,mold,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
info = psb_success_
if (allocated(x%v)) &
@@ -328,17 +440,25 @@ contains
else
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine z_vect_bld_mn
subroutine z_vect_bld_en(x,n,mold)
subroutine z_vect_bld_en(x,n,mold,scratch)
integer(psb_epk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (allocated(x%v)) &
& call x%free(info)
@@ -348,7 +468,7 @@ contains
else
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
endif
if (info == psb_success_) call x%v%bld(n)
if (info == psb_success_) call x%v%bld(n,scratch=scratch_)
end subroutine z_vect_bld_en
@@ -450,8 +570,19 @@ contains
else
info = psb_err_alloc_dealloc_
end if
call x%set_bld()
end subroutine z_vect_all
subroutine z_vect_reinit(x, info)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) call x%v%reinit(info)
call x%set_upd()
end subroutine z_vect_reinit
subroutine z_vect_reall(n, x, info)
implicit none
@@ -476,16 +607,17 @@ contains
end subroutine z_vect_zero
subroutine z_vect_asb(n, x, info)
subroutine z_vect_asb(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if (allocated(x%v)) then
call x%v%asb(n,info)
call x%v%asb(n,info,scratch=scratch)
end if
end subroutine z_vect_asb
@@ -540,11 +672,11 @@ contains
end subroutine z_vect_free
subroutine z_vect_ins_a(n,irl,val,x,info)
subroutine z_vect_ins_a(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -557,15 +689,15 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine z_vect_ins_a
subroutine z_vect_ins_v(n,irl,val,x,info)
subroutine z_vect_ins_v(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n, maxr
class(psb_i_vect_type), intent(inout) :: irl
class(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -578,7 +710,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
call x%v%ins(n,irl%v,val%v,dupl,maxr,info)
end subroutine z_vect_ins_v
base/modules/tools/psb_c_tools_mod.F90
+4 -2
View File
@@ -70,7 +70,7 @@ Module psb_c_tools_mod
interface psb_geasb
subroutine psb_casb_vect(x, desc_a, info,mold, scratch)
subroutine psb_casb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -78,6 +78,7 @@ Module psb_c_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_casb_vect
subroutine psb_casb_vect_r2(x, desc_a, info,mold, scratch)
import
@@ -250,13 +251,14 @@ Module psb_c_tools_mod
end interface
interface psb_spasb
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
import
implicit none
type(psb_cspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_c_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
base/modules/tools/psb_d_tools_mod.F90
+2 -2
View File
@@ -257,11 +257,11 @@ Module psb_d_tools_mod
type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dspasb
end interface
base/modules/tools/psb_i_tools_mod.F90
+2 -1
View File
@@ -69,7 +69,7 @@ Module psb_i_tools_mod
interface psb_geasb
subroutine psb_iasb_vect(x, desc_a, info,mold, scratch)
subroutine psb_iasb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -77,6 +77,7 @@ Module psb_i_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_iasb_vect
subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch)
import
base/modules/tools/psb_l_tools_mod.F90
+2 -1
View File
@@ -69,7 +69,7 @@ Module psb_l_tools_mod
interface psb_geasb
subroutine psb_lasb_vect(x, desc_a, info,mold, scratch)
subroutine psb_lasb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -77,6 +77,7 @@ Module psb_l_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_lasb_vect
subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch)
import
base/modules/tools/psb_s_tools_mod.F90
+4 -2
View File
@@ -70,7 +70,7 @@ Module psb_s_tools_mod
interface psb_geasb
subroutine psb_sasb_vect(x, desc_a, info,mold, scratch)
subroutine psb_sasb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -78,6 +78,7 @@ Module psb_s_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_sasb_vect
subroutine psb_sasb_vect_r2(x, desc_a, info,mold, scratch)
import
@@ -250,13 +251,14 @@ Module psb_s_tools_mod
end interface
interface psb_spasb
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
import
implicit none
type(psb_sspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
base/modules/tools/psb_z_tools_mod.F90
+4 -2
View File
@@ -70,7 +70,7 @@ Module psb_z_tools_mod
interface psb_geasb
subroutine psb_zasb_vect(x, desc_a, info,mold, scratch)
subroutine psb_zasb_vect(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -78,6 +78,7 @@ Module psb_z_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_zasb_vect
subroutine psb_zasb_vect_r2(x, desc_a, info,mold, scratch)
import
@@ -250,13 +251,14 @@ Module psb_z_tools_mod
end interface
interface psb_spasb
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
import
implicit none
type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: upd
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: afmt
class(psb_z_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
base/tools/psb_callc.f90
+3 -5
View File
@@ -109,12 +109,10 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then
base/tools/psb_casb.f90
+75 -31
View File
@@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false.
!
subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
subroutine psb_casb_vect(x, desc_a, info, mold, scratch, dupl)
use psb_base_mod, psb_protect_name => psb_casb_vect
implicit none
@@ -60,6 +60,7 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables
type(psb_ctxt_type) :: ctxt
@@ -80,10 +81,9 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
@@ -100,39 +100,83 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
dupl_ = x%get_dupl()
if (try_newins) then
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold,scratch=scratch_)
else
if (x%is_bld().and.present(dupl)) then
call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
else
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
if (x%is_bld().and.present(dupl)) then
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
call x%cnv(mold)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
@@ -202,7 +246,7 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info)
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
base/tools/psb_cins.f90
+5 -5
View File
@@ -57,7 +57,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@@ -127,7 +127,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -198,7 +198,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@@ -261,7 +261,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -368,7 +368,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then
base/tools/psb_cspasb.f90
+9 -3
View File
@@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory)
!
!
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
use psb_base_mod, psb_protect_name => psb_cspasb
use psb_sort_mod
use psi_mod
@@ -59,6 +59,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
character(len=*), optional, intent(in) :: afmt
class(psb_c_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
!....Locals....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act
@@ -103,7 +104,12 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
!check on errors encountered in psdspins
if (a%is_bld()) then
dupl_ = a%get_dupl()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = a%get_dupl()
end if
!
! First case: we come from a fresh build.
!
@@ -180,7 +186,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
if (bld_and_) then
!!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info)
!!$ call a%split_nd(n_row,n_col,info)
!!$ block
!!$ character(len=1024) :: fname
!!$ type(psb_c_coo_sparse_mat) :: acoo
base/tools/psb_dallc.f90
+3 -6
View File
@@ -109,13 +109,10 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
!!$ else
!!$ dupl_ = psb_dupl_def_
end if
!!$ call x%set_dupl(dupl_)
call x%set_bld()
if (present(dupl)) then
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then
base/tools/psb_dasb.f90
+15 -19
View File
@@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false.
!
subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
subroutine psb_dasb_vect(x, desc_a, info, mold, scratch, dupl)
use psb_base_mod, psb_protect_name => psb_dasb_vect
implicit none
@@ -69,7 +69,6 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
!logical, parameter :: try_newins = .true.
info = psb_success_
name = 'psb_dgeasb_v'
@@ -82,7 +81,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
@@ -95,32 +94,30 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (try_newins) then
!!$ if (present(dupl)) then
!!$ call x%set_dupl(dupl)
!!$ end if
dupl_ = x%get_dupl()
dupl_ = x%get_dupl()
if (try_newins) then
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
call x%bld(ncol,mold=mold,scratch=scratch_)
else
if (x%is_bld().and.present(dupl)) then
call x%set_dupl(dupl)
call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
real(psb_dpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
@@ -129,8 +126,8 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info)
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
@@ -143,14 +140,12 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
else
dupl_ = x%get_dupl()
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
if (x%is_bld().and.present(dupl)) then
!!$ call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
@@ -169,7 +164,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
end block
end if
call x%asb(ncol,info)
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
@@ -182,6 +177,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch,dupl)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if
call psb_erractionrestore(err_act)
return
@@ -250,7 +246,7 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info)
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
base/tools/psb_dins.f90
+2 -2
View File
@@ -57,7 +57,7 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@@ -198,7 +198,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
base/tools/psb_dspins.F90
+1 -5
View File
@@ -138,11 +138,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
if (.not.a%is_bld()) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
end if
if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
base/tools/psb_iallc.f90
+3 -5
View File
@@ -109,12 +109,10 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then
base/tools/psb_iasb.f90
+75 -31
View File
@@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false.
!
subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
subroutine psb_iasb_vect(x, desc_a, info, mold, scratch, dupl)
use psb_base_mod, psb_protect_name => psb_iasb_vect
implicit none
@@ -60,6 +60,7 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables
type(psb_ctxt_type) :: ctxt
@@ -80,10 +81,9 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
@@ -100,39 +100,83 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
dupl_ = x%get_dupl()
if (try_newins) then
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold,scratch=scratch_)
else
if (x%is_bld().and.present(dupl)) then
call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
integer(psb_ipk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
else
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
integer(psb_ipk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
if (x%is_bld().and.present(dupl)) then
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
integer(psb_ipk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
call x%cnv(mold)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
@@ -202,7 +246,7 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch)
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info)
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
base/tools/psb_iins.f90
+5 -5
View File
@@ -57,7 +57,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@@ -127,7 +127,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -198,7 +198,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@@ -261,7 +261,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -368,7 +368,7 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then
base/tools/psb_lallc.f90
+3 -5
View File
@@ -109,12 +109,10 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then
base/tools/psb_lasb.f90
+75 -31
View File
@@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false.
!
subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
subroutine psb_lasb_vect(x, desc_a, info, mold, scratch, dupl)
use psb_base_mod, psb_protect_name => psb_lasb_vect
implicit none
@@ -60,6 +60,7 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables
type(psb_ctxt_type) :: ctxt
@@ -80,10 +81,9 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
@@ -100,39 +100,83 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
dupl_ = x%get_dupl()
if (try_newins) then
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold,scratch=scratch_)
else
if (x%is_bld().and.present(dupl)) then
call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
integer(psb_lpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
else
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
integer(psb_lpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
if (x%is_bld().and.present(dupl)) then
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
integer(psb_lpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
call x%cnv(mold)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
@@ -202,7 +246,7 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch)
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info)
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
base/tools/psb_lins.f90
+5 -5
View File
@@ -57,7 +57,7 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@@ -127,7 +127,7 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -198,7 +198,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@@ -261,7 +261,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -368,7 +368,7 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then
base/tools/psb_sallc.f90
+3 -5
View File
@@ -109,12 +109,10 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then
base/tools/psb_sasb.f90
+75 -31
View File
@@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false.
!
subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
subroutine psb_sasb_vect(x, desc_a, info, mold, scratch, dupl)
use psb_base_mod, psb_protect_name => psb_sasb_vect
implicit none
@@ -60,6 +60,7 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables
type(psb_ctxt_type) :: ctxt
@@ -80,10 +81,9 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
@@ -100,39 +100,83 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
dupl_ = x%get_dupl()
if (try_newins) then
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold,scratch=scratch_)
else
if (x%is_bld().and.present(dupl)) then
call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
real(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
else
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
real(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
if (x%is_bld().and.present(dupl)) then
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
real(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
call x%cnv(mold)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
@@ -202,7 +246,7 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch)
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info)
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
base/tools/psb_sins.f90
+5 -5
View File
@@ -57,7 +57,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@@ -127,7 +127,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -198,7 +198,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@@ -261,7 +261,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -368,7 +368,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then
base/tools/psb_sspasb.f90
+9 -3
View File
@@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory)
!
!
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
use psb_base_mod, psb_protect_name => psb_sspasb
use psb_sort_mod
use psi_mod
@@ -59,6 +59,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
!....Locals....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act
@@ -103,7 +104,12 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
!check on errors encountered in psdspins
if (a%is_bld()) then
dupl_ = a%get_dupl()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = a%get_dupl()
end if
!
! First case: we come from a fresh build.
!
@@ -180,7 +186,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
if (bld_and_) then
!!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info)
!!$ call a%split_nd(n_row,n_col,info)
!!$ block
!!$ character(len=1024) :: fname
!!$ type(psb_s_coo_sparse_mat) :: acoo
base/tools/psb_zallc.f90
+3 -5
View File
@@ -109,12 +109,10 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode)
else
bldmode_ = psb_matbld_noremote_
end if
call x%set_bld()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_dupl(dupl)
end if
call x%set_remote_build(bldmode_)
call x%set_nrmv(izero)
if (x%is_remote_build()) then
base/tools/psb_zasb.f90
+75 -31
View File
@@ -51,7 +51,7 @@
! scratch - logical, optional If true, allocate without checking/zeroing contents.
! default: .false.
!
subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
subroutine psb_zasb_vect(x, desc_a, info, mold, scratch, dupl)
use psb_base_mod, psb_protect_name => psb_zasb_vect
implicit none
@@ -60,6 +60,7 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
! local variables
type(psb_ctxt_type) :: ctxt
@@ -80,10 +81,9 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
@@ -100,39 +100,83 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
dupl_ = x%get_dupl()
if (try_newins) then
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold,scratch=scratch_)
else
if (x%is_bld().and.present(dupl)) then
call x%set_dupl(dupl)
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_dpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
else
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_dpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
if (x%is_bld().and.present(dupl)) then
dupl_ = dupl
end if
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_dpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,nrow,info)
end block
end if
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
call x%asb(ncol,info,scratch=scratch)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
call x%cnv(mold)
end if
call x%cnv(mold)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
@@ -202,7 +246,7 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch)
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info)
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
base/tools/psb_zins.f90
+5 -5
View File
@@ -57,7 +57,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_ipk_) :: i, loc_rows, loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
@@ -127,7 +127,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,info)
call x%ins(m,irl,val,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -198,7 +198,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local)
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_ipk_) :: i, loc_rows, loc_cols, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
@@ -261,7 +261,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,info)
call x%ins(m,irl,lval,loc_rows,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -368,7 +368,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),loc_rows,info)
if (info /= 0) exit
end do
if (info /= 0) then
base/tools/psb_zspasb.f90
+9 -3
View File
@@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory)
!
!
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and)
use psb_base_mod, psb_protect_name => psb_zspasb
use psb_sort_mod
use psi_mod
@@ -59,6 +59,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
character(len=*), optional, intent(in) :: afmt
class(psb_z_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
integer(psb_ipk_), optional, intent(in) :: dupl
!....Locals....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act
@@ -103,7 +104,12 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
!check on errors encountered in psdspins
if (a%is_bld()) then
dupl_ = a%get_dupl()
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = a%get_dupl()
end if
!
! First case: we come from a fresh build.
!
@@ -180,7 +186,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
if (bld_and_) then
!!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info)
!!$ call a%split_nd(n_row,n_col,info)
!!$ block
!!$ character(len=1024) :: fname
!!$ type(psb_z_coo_sparse_mat) :: acoo
cuda/psb_c_cuda_vect_mod.F90
+36 -12
View File
@@ -560,12 +560,20 @@ contains
end subroutine c_cuda_sctb_buf
subroutine c_cuda_bld_x(x,this)
subroutine c_cuda_bld_x(x,this,scratch)
use psb_base_mod
complex(psb_spk_), intent(in) :: this(:)
class(psb_c_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@@ -578,11 +586,19 @@ contains
end subroutine c_cuda_bld_x
subroutine c_cuda_bld_mn(x,n)
subroutine c_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'c_cuda_bld_n',i_err=(/n,n,n,n,n/))
@@ -679,26 +695,34 @@ contains
call x%set_scal(czero)
end subroutine c_cuda_zero
subroutine c_cuda_asb_m(n, x, info)
subroutine c_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_c_base_vect_type%asb(n,info)
call x%psb_c_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_c_base_vect_type%asb(n,info)
call x%psb_c_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine c_cuda_vect_finalize
subroutine c_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine c_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if
if (info /= 0) then
@@ -1295,11 +1319,11 @@ contains
end subroutine c_cuda_ins_v
subroutine c_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine c_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_c_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_c_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine c_cuda_ins_a
cuda/psb_d_cuda_vect_mod.F90
+32 -8
View File
@@ -560,12 +560,20 @@ contains
end subroutine d_cuda_sctb_buf
subroutine d_cuda_bld_x(x,this)
subroutine d_cuda_bld_x(x,this,scratch)
use psb_base_mod
real(psb_dpk_), intent(in) :: this(:)
class(psb_d_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@@ -578,11 +586,19 @@ contains
end subroutine d_cuda_bld_x
subroutine d_cuda_bld_mn(x,n)
subroutine d_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'d_cuda_bld_n',i_err=(/n,n,n,n,n/))
@@ -679,26 +695,34 @@ contains
call x%set_scal(dzero)
end subroutine d_cuda_zero
subroutine d_cuda_asb_m(n, x, info)
subroutine d_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_d_base_vect_type%asb(n,info)
call x%psb_d_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_d_base_vect_type%asb(n,info)
call x%psb_d_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@@ -1256,7 +1280,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -1299,7 +1323,7 @@ contains
use psi_serial_mod
implicit none
class(psb_d_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
cuda/psb_i_cuda_vect_mod.F90
+36 -12
View File
@@ -542,12 +542,20 @@ contains
end subroutine i_cuda_sctb_buf
subroutine i_cuda_bld_x(x,this)
subroutine i_cuda_bld_x(x,this,scratch)
use psb_base_mod
integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@@ -560,11 +568,19 @@ contains
end subroutine i_cuda_bld_x
subroutine i_cuda_bld_mn(x,n)
subroutine i_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'i_cuda_bld_n',i_err=(/n,n,n,n,n/))
@@ -661,26 +677,34 @@ contains
call x%set_scal(izero)
end subroutine i_cuda_zero
subroutine i_cuda_asb_m(n, x, info)
subroutine i_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_i_base_vect_type%asb(n,info)
call x%psb_i_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_i_base_vect_type%asb(n,info)
call x%psb_i_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@@ -814,11 +838,11 @@ contains
call x%free(info)
end subroutine i_cuda_vect_finalize
subroutine i_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine i_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -847,7 +871,7 @@ contains
if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if
if (info /= 0) then
@@ -857,11 +881,11 @@ contains
end subroutine i_cuda_ins_v
subroutine i_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine i_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -870,7 +894,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_i_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_i_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine i_cuda_ins_a
cuda/psb_s_cuda_vect_mod.F90
+36 -12
View File
@@ -560,12 +560,20 @@ contains
end subroutine s_cuda_sctb_buf
subroutine s_cuda_bld_x(x,this)
subroutine s_cuda_bld_x(x,this,scratch)
use psb_base_mod
real(psb_spk_), intent(in) :: this(:)
class(psb_s_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@@ -578,11 +586,19 @@ contains
end subroutine s_cuda_bld_x
subroutine s_cuda_bld_mn(x,n)
subroutine s_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'s_cuda_bld_n',i_err=(/n,n,n,n,n/))
@@ -679,26 +695,34 @@ contains
call x%set_scal(szero)
end subroutine s_cuda_zero
subroutine s_cuda_asb_m(n, x, info)
subroutine s_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_s_base_vect_type%asb(n,info)
call x%psb_s_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_s_base_vect_type%asb(n,info)
call x%psb_s_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine s_cuda_vect_finalize
subroutine s_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine s_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if
if (info /= 0) then
@@ -1295,11 +1319,11 @@ contains
end subroutine s_cuda_ins_v
subroutine s_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine s_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_s_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_s_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine s_cuda_ins_a
cuda/psb_z_cuda_vect_mod.F90
+36 -12
View File
@@ -560,12 +560,20 @@ contains
end subroutine z_cuda_sctb_buf
subroutine z_cuda_bld_x(x,this)
subroutine z_cuda_bld_x(x,this,scratch)
use psb_base_mod
complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
info=psb_err_alloc_request_
@@ -578,11 +586,19 @@ contains
end subroutine z_cuda_bld_x
subroutine z_cuda_bld_mn(x,n)
subroutine z_cuda_bld_mn(x,n,scratch)
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_cuda), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%all(n,info)
if (info /= 0) then
call psb_errpush(info,'z_cuda_bld_n',i_err=(/n,n,n,n,n/))
@@ -679,26 +695,34 @@ contains
call x%set_scal(zzero)
end subroutine z_cuda_zero
subroutine z_cuda_asb_m(n, x, info)
subroutine z_cuda_asb_m(n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = getMultiVecDeviceSize(x%deviceVect)
if (nd < n) then
call x%sync()
call x%psb_z_base_vect_type%asb(n,info)
call x%psb_z_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
else !
if (x%get_nrows()<n) then
call x%psb_z_base_vect_type%asb(n,info)
call x%psb_z_base_vect_type%asb(n,info,scratch=scratch_)
if (info == psb_success_) call x%sync_space(info)
call x%set_host()
end if
@@ -1252,11 +1276,11 @@ contains
call x%free(info)
end subroutine z_cuda_vect_finalize
subroutine z_cuda_ins_v(n,irl,val,dupl,x,info)
subroutine z_cuda_ins_v(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -1285,7 +1309,7 @@ contains
if (.not.done_cuda) then
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
call x%ins(n,irl%v,val%v,dupl,info)
call x%ins(n,irl%v,val%v,dupl,maxr,info)
end if
if (info /= 0) then
@@ -1295,11 +1319,11 @@ contains
end subroutine z_cuda_ins_v
subroutine z_cuda_ins_a(n,irl,val,dupl,x,info)
subroutine z_cuda_ins_a(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_vect_cuda), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -1308,7 +1332,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_z_base_vect_type%ins(n,irl,val,dupl,info)
call x%psb_z_base_vect_type%ins(n,irl,val,dupl,maxr,info)
call x%set_host()
end subroutine z_cuda_ins_a
openacc/psb_c_oacc_vect_mod.F90
+35 -12
View File
@@ -620,11 +620,11 @@ contains
end subroutine inner_gth
end subroutine c_oacc_gthzv_x
subroutine c_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine c_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_c_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_c_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -661,7 +661,7 @@ contains
type is (psb_c_vect_oacc)
if (vval%is_dev()) call vval%sync()
end select
call x%ins(n, irl%v, val%v, dupl, info)
call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if
if (info /= 0) then
@@ -671,11 +671,11 @@ contains
end subroutine c_oacc_ins_v
subroutine c_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine c_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_c_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -684,19 +684,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_c_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_c_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine c_oacc_ins_a
subroutine c_oacc_bld_mn(x, n)
subroutine c_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@@ -709,13 +716,21 @@ contains
end subroutine c_oacc_bld_mn
subroutine c_oacc_bld_x(x, this)
subroutine c_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
complex(psb_spk_), intent(in) :: this(:)
class(psb_c_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@@ -730,27 +745,35 @@ contains
end subroutine c_oacc_bld_x
subroutine c_oacc_asb_m(n, x, info)
subroutine c_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_c_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_c_base_vect_type%asb(n, info)
call x%psb_c_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_c_base_vect_type%asb(n, info)
call x%psb_c_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
openacc/psb_d_oacc_vect_mod.F90
+35 -12
View File
@@ -620,11 +620,11 @@ contains
end subroutine inner_gth
end subroutine d_oacc_gthzv_x
subroutine d_oacc_ins_v(n, irl, val, dupl, x,maxr, info)
subroutine d_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_d_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -661,7 +661,7 @@ contains
type is (psb_d_vect_oacc)
if (vval%is_dev()) call vval%sync()
end select
call x%ins(n, irl%v, val%v, dupl,maxr, info)
call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if
if (info /= 0) then
@@ -671,11 +671,11 @@ contains
end subroutine d_oacc_ins_v
subroutine d_oacc_ins_a(n, irl, val, dupl, x,maxr, info)
subroutine d_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -684,19 +684,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_d_base_vect_type%ins(n, irl, val, dupl,maxr, info)
call x%psb_d_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine d_oacc_ins_a
subroutine d_oacc_bld_mn(x, n)
subroutine d_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@@ -709,13 +716,21 @@ contains
end subroutine d_oacc_bld_mn
subroutine d_oacc_bld_x(x, this)
subroutine d_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
real(psb_dpk_), intent(in) :: this(:)
class(psb_d_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@@ -730,27 +745,35 @@ contains
end subroutine d_oacc_bld_x
subroutine d_oacc_asb_m(n, x, info)
subroutine d_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_d_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_d_base_vect_type%asb(n, info)
call x%psb_d_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_d_base_vect_type%asb(n, info)
call x%psb_d_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
openacc/psb_i_oacc_vect_mod.F90
+35 -12
View File
@@ -274,11 +274,11 @@ contains
end subroutine inner_gth
end subroutine i_oacc_gthzv_x
subroutine i_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine i_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_i_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -315,7 +315,7 @@ contains
type is (psb_i_vect_oacc)
if (vval%is_dev()) call vval%sync()
end select
call x%ins(n, irl%v, val%v, dupl, info)
call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if
if (info /= 0) then
@@ -325,11 +325,11 @@ contains
end subroutine i_oacc_ins_v
subroutine i_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine i_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_i_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -338,19 +338,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_i_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_i_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine i_oacc_ins_a
subroutine i_oacc_bld_mn(x, n)
subroutine i_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@@ -363,13 +370,21 @@ contains
end subroutine i_oacc_bld_mn
subroutine i_oacc_bld_x(x, this)
subroutine i_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@@ -384,27 +399,35 @@ contains
end subroutine i_oacc_bld_x
subroutine i_oacc_asb_m(n, x, info)
subroutine i_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_i_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_i_base_vect_type%asb(n, info)
call x%psb_i_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_i_base_vect_type%asb(n, info)
call x%psb_i_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
openacc/psb_l_oacc_vect_mod.F90
+35 -12
View File
@@ -276,11 +276,11 @@ contains
end subroutine inner_gth
end subroutine l_oacc_gthzv_x
subroutine l_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine l_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_l_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_l_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -317,7 +317,7 @@ contains
type is (psb_l_vect_oacc)
if (vval%is_dev()) call vval%sync()
end select
call x%ins(n, irl%v, val%v, dupl, info)
call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if
if (info /= 0) then
@@ -327,11 +327,11 @@ contains
end subroutine l_oacc_ins_v
subroutine l_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine l_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_l_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -340,19 +340,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_l_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_l_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine l_oacc_ins_a
subroutine l_oacc_bld_mn(x, n)
subroutine l_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@@ -365,13 +372,21 @@ contains
end subroutine l_oacc_bld_mn
subroutine l_oacc_bld_x(x, this)
subroutine l_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
integer(psb_lpk_), intent(in) :: this(:)
class(psb_l_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@@ -386,27 +401,35 @@ contains
end subroutine l_oacc_bld_x
subroutine l_oacc_asb_m(n, x, info)
subroutine l_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_l_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_l_base_vect_type%asb(n, info)
call x%psb_l_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_l_base_vect_type%asb(n, info)
call x%psb_l_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
openacc/psb_s_oacc_vect_mod.F90
+35 -12
View File
@@ -620,11 +620,11 @@ contains
end subroutine inner_gth
end subroutine s_oacc_gthzv_x
subroutine s_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine s_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_s_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_s_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -661,7 +661,7 @@ contains
type is (psb_s_vect_oacc)
if (vval%is_dev()) call vval%sync()
end select
call x%ins(n, irl%v, val%v, dupl, info)
call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if
if (info /= 0) then
@@ -671,11 +671,11 @@ contains
end subroutine s_oacc_ins_v
subroutine s_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine s_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_s_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -684,19 +684,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_s_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_s_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine s_oacc_ins_a
subroutine s_oacc_bld_mn(x, n)
subroutine s_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@@ -709,13 +716,21 @@ contains
end subroutine s_oacc_bld_mn
subroutine s_oacc_bld_x(x, this)
subroutine s_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
real(psb_spk_), intent(in) :: this(:)
class(psb_s_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@@ -730,27 +745,35 @@ contains
end subroutine s_oacc_bld_x
subroutine s_oacc_asb_m(n, x, info)
subroutine s_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_s_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_s_base_vect_type%asb(n, info)
call x%psb_s_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_s_base_vect_type%asb(n, info)
call x%psb_s_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
openacc/psb_z_oacc_vect_mod.F90
+35 -12
View File
@@ -620,11 +620,11 @@ contains
end subroutine inner_gth
end subroutine z_oacc_gthzv_x
subroutine z_oacc_ins_v(n, irl, val, dupl, x, info)
subroutine z_oacc_ins_v(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_z_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_z_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
@@ -661,7 +661,7 @@ contains
type is (psb_z_vect_oacc)
if (vval%is_dev()) call vval%sync()
end select
call x%ins(n, irl%v, val%v, dupl, info)
call x%ins(n, irl%v, val%v, dupl, maxr, info)
end if
if (info /= 0) then
@@ -671,11 +671,11 @@ contains
end subroutine z_oacc_ins_v
subroutine z_oacc_ins_a(n, irl, val, dupl, x, info)
subroutine z_oacc_ins_a(n, irl, val, dupl, x, maxr, info)
use psi_serial_mod
implicit none
class(psb_z_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl, maxr
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
@@ -684,19 +684,26 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call x%psb_z_base_vect_type%ins(n, irl, val, dupl, info)
call x%psb_z_base_vect_type%ins(n, irl, val, dupl, maxr, info)
call x%set_host()
end subroutine z_oacc_ins_a
subroutine z_oacc_bld_mn(x, n)
subroutine z_oacc_bld_mn(x, n,scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call x%all(ione*n, info)
if (info /= 0) then
@@ -709,13 +716,21 @@ contains
end subroutine z_oacc_bld_mn
subroutine z_oacc_bld_x(x, this)
subroutine z_oacc_bld_x(x, this,scratch)
use psb_base_mod
implicit none
complex(psb_dpk_), intent(in) :: this(:)
class(psb_z_vect_oacc), intent(inout) :: x
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_ipk_) :: info
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call x%free(info)
call psb_realloc(size(this), x%v, info)
if (info /= 0) then
@@ -730,27 +745,35 @@ contains
end subroutine z_oacc_bld_x
subroutine z_oacc_asb_m(n, x, info)
subroutine z_oacc_asb_m(n, x, info, scratch)
use psb_base_mod
implicit none
integer(psb_mpk_), intent(in) :: n
class(psb_z_vect_oacc), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
integer(psb_mpk_) :: nd
info = psb_success_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
if (x%is_dev()) then
nd = size(x%v)
if (nd < n) then
call x%sync()
call x%psb_z_base_vect_type%asb(n, info)
call x%psb_z_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
else
if (size(x%v) < n) then
call x%psb_z_base_vect_type%asb(n, info)
call x%psb_z_base_vect_type%asb(n, info, scratch=scratch_)
if (info == psb_success_) call x%sync()
call x%set_host()
end if
test/pdegen/psb_d_pde2d.F90
+6 -6
View File
@@ -406,11 +406,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@@ -558,9 +558,9 @@ contains
t1 = psb_wtime()
if (info == psb_success_) then
if (present(amold)) then
call psb_spasb(a,desc_a,info,mold=amold)
call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_)
else
call psb_spasb(a,desc_a,info,afmt=afmt)
call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_)
end if
end if
call psb_barrier(ctxt)
@@ -570,8 +570,8 @@ contains
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='asb rout.'
test/pdegen/psb_d_pde3d.F90
+2 -2
View File
@@ -435,11 +435,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz, &
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
test/pdegen/psb_s_pde2d.F90
+6 -6
View File
@@ -406,11 +406,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@@ -558,9 +558,9 @@ contains
t1 = psb_wtime()
if (info == psb_success_) then
if (present(amold)) then
call psb_spasb(a,desc_a,info,mold=amold)
call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_)
else
call psb_spasb(a,desc_a,info,afmt=afmt)
call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_)
end if
end if
call psb_barrier(ctxt)
@@ -570,8 +570,8 @@ contains
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='asb rout.'
test/pdegen/psb_s_pde3d.F90
+6 -6
View File
@@ -435,11 +435,11 @@ contains
if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz, &
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
! define rhs from boundary conditions; also build initial guess
if (info == psb_success_) call psb_geall(xv,desc_a,info)
if (info == psb_success_) call psb_geall(bv,desc_a,info,&
& bldmode=psb_matbld_remote_,dupl=psb_dupl_add_)
& bldmode=psb_matbld_remote_)
call psb_barrier(ctxt)
talc = psb_wtime()-t0
@@ -606,9 +606,9 @@ contains
t1 = psb_wtime()
if (info == psb_success_) then
if (present(amold)) then
call psb_spasb(a,desc_a,info,mold=amold)
call psb_spasb(a,desc_a,info,mold=amold,dupl=psb_dupl_add_)
else
call psb_spasb(a,desc_a,info,afmt=afmt)
call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_add_)
end if
end if
call psb_barrier(ctxt)
@@ -618,8 +618,8 @@ contains
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold)
if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold,dupl=psb_dupl_add_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='asb rout.'