fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-19 20:32:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

Fix multivect handling

Browse Source
This commit is contained in:
sfilippone
2026-01-13 15:26:11 +01:00
parent 82d7f0fe7e
commit 3337a12e59
36 changed files with 2206 additions and 814 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/serial/psb_c_base_vect_mod.F90
+354 -59
View File
@@ -397,22 +397,6 @@ contains
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
@@ -431,6 +415,22 @@ contains
end subroutine c_base_mold
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
!
! Insert a bunch of values at specified positions.
!
@@ -491,7 +491,9 @@ contains
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_
@@ -662,7 +664,7 @@ contains
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = czero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
@@ -674,7 +676,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. czero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
@@ -745,7 +747,7 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = czero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
@@ -757,7 +759,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. czero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
@@ -815,8 +817,6 @@ contains
call x%set_null()
end subroutine c_base_free
!
!> Function base_free_buffer:
!! \memberof psb_c_base_vect_type
@@ -2440,6 +2440,18 @@ module psb_c_base_multivect_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
@@ -2458,6 +2470,22 @@ module psb_c_base_multivect_mod
procedure, pass(x) :: zero => c_base_mlv_zero
procedure, pass(x) :: asb => c_base_mlv_asb
procedure, pass(x) :: free => c_base_mlv_free
procedure, pass(x) :: reinit => c_base_mlv_reinit
procedure, pass(x) :: set_ncfs => c_base_mlv_set_ncfs
procedure, pass(x) :: get_ncfs => c_base_mlv_get_ncfs
procedure, pass(x) :: set_dupl => c_base_mlv_set_dupl
procedure, pass(x) :: get_dupl => c_base_mlv_get_dupl
procedure, pass(x) :: set_state => c_base_mlv_set_state
procedure, pass(x) :: set_null => c_base_mlv_set_null
procedure, pass(x) :: set_bld => c_base_mlv_set_bld
procedure, pass(x) :: set_upd => c_base_mlv_set_upd
procedure, pass(x) :: set_asb => c_base_mlv_set_asb
procedure, pass(x) :: get_state => c_base_mlv_get_state
procedure, pass(x) :: is_null => c_base_mlv_is_null
procedure, pass(x) :: is_bld => c_base_mlv_is_bld
procedure, pass(x) :: is_upd => c_base_mlv_is_upd
procedure, pass(x) :: is_asb => c_base_mlv_is_asb
procedure, pass(x) :: base_cpy => c_base_mlv_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -2571,7 +2599,8 @@ contains
integer(psb_ipk_) :: info
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
call this%asb(size(x,dim=1,kind=psb_ipk_),&
& size(x,dim=2,kind=psb_ipk_),info)
end function constructor
@@ -2621,12 +2650,21 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine c_base_mlv_bld_n(x,m,n)
subroutine c_base_mlv_bld_n(x,m,n,scratch)
use psb_realloc_mod
integer(psb_ipk_), intent(in) :: m,n
class(psb_c_base_multivect_type), intent(inout) :: x
integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info)
@@ -2648,6 +2686,10 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,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_mlv_all
@@ -2669,6 +2711,22 @@ contains
end subroutine c_base_mlv_mold
subroutine c_base_mlv_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_c_base_multivect_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_mlv_reinit
!
! Insert a bunch of values at specified positions.
!
@@ -2696,57 +2754,123 @@ contains
!! \param info return code
!!
!
subroutine c_base_mlv_ins(n,irl,val,dupl,x,info)
subroutine c_base_mlv_ins(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_base_multivect_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, nc, 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,1)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
nc = size(x%v,2)
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_realloc(isz,nc,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)
case(psb_dupl_add_)
else if (x%is_upd()) then
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
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,1)
nc = size(x%v,2)
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 default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i),:) = x%v(irl(i),:) + val(i,:)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v,1)
nc = size(x%v,2)
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
call psb_errpush(info,'base_mlv_vect_ins')
return
@@ -2766,6 +2890,7 @@ contains
class(psb_c_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=czero
call x%set_host()
end subroutine c_base_mlv_zero
@@ -2784,19 +2909,73 @@ contains
!!
!
subroutine c_base_mlv_asb(m,n, x, info)
subroutine c_base_mlv_asb(m,n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_c_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(psb_spk_), 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()
xvsz = psb_size(x%v)
call psb_realloc(m,n,vv,info)
vv(:,:) = czero
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 (any(vv(x%iv(i),:).ne.czero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i),:) = x%v(i,:)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) &
& call psb_realloc(m,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() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%set_host()
call x%set_asb()
call x%sync()
end subroutine c_base_mlv_asb
@@ -2822,6 +3001,103 @@ contains
end subroutine c_base_mlv_free
function c_base_mlv_get_ncfs(x) result(res)
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function c_base_mlv_get_ncfs
function c_base_mlv_get_dupl(x) result(res)
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function c_base_mlv_get_dupl
function c_base_mlv_get_state(x) result(res)
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function c_base_mlv_get_state
function c_base_mlv_is_null(x) result(res)
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function c_base_mlv_is_null
function c_base_mlv_is_bld(x) result(res)
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function c_base_mlv_is_bld
function c_base_mlv_is_upd(x) result(res)
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function c_base_mlv_is_upd
function c_base_mlv_is_asb(x) result(res)
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function c_base_mlv_is_asb
subroutine c_base_mlv_set_ncfs(n,x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine c_base_mlv_set_ncfs
subroutine c_base_mlv_set_dupl(n,x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine c_base_mlv_set_dupl
subroutine c_base_mlv_set_state(n,x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine c_base_mlv_set_state
subroutine c_base_mlv_set_null(x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine c_base_mlv_set_null
subroutine c_base_mlv_set_bld(x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine c_base_mlv_set_bld
subroutine c_base_mlv_set_upd(x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine c_base_mlv_set_upd
subroutine c_base_mlv_set_asb(x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine c_base_mlv_set_asb
!
@@ -2918,6 +3194,25 @@ contains
res = .true.
end function c_base_mlv_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine c_base_mlv_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
class(psb_c_base_multivect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine c_base_mlv_cpy
!
! Size info.
@@ -2960,7 +3255,7 @@ contains
integer(psb_epk_) :: res
! Force 8-byte integers.
res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols()
res = (1_psb_epk_ * (2*psb_sizeof_sp)) * x%get_nrows() * x%get_ncols()
end function c_base_mlv_sizeof
base/modules/serial/psb_c_vect_mod.F90
+3 -3
View File
@@ -1887,11 +1887,11 @@ contains
end subroutine c_mvect_free
subroutine c_mvect_ins(n,irl,val,x,info)
subroutine c_mvect_ins(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_c_multivect_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
@@ -1904,7 +1904,7 @@ 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_mvect_ins
base/modules/serial/psb_d_base_vect_mod.F90
+353 -58
View File
@@ -404,22 +404,6 @@ contains
end subroutine d_base_all
subroutine d_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = dzero
call x%set_host()
call x%set_upd()
end if
end subroutine d_base_reinit
!> Function base_mold:
!! \memberof psb_d_base_vect_type
!! \brief Mold method: return a variable with the same dynamic type
@@ -438,6 +422,22 @@ contains
end subroutine d_base_mold
subroutine d_base_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:) = dzero
call x%set_host()
call x%set_upd()
end if
end subroutine d_base_reinit
!
! Insert a bunch of values at specified positions.
!
@@ -498,7 +498,9 @@ contains
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_
@@ -681,7 +683,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
@@ -752,7 +754,7 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = dzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
@@ -764,7 +766,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. dzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
@@ -822,8 +824,6 @@ contains
call x%set_null()
end subroutine d_base_free
!
!> Function base_free_buffer:
!! \memberof psb_d_base_vect_type
@@ -2619,6 +2619,18 @@ module psb_d_base_multivect_mod
real(psb_dpk_), allocatable :: v(:,:)
real(psb_dpk_), allocatable :: combuf(:)
integer(psb_mpk_), allocatable :: comid(:,:)
!> vector bldstate:
!! null: pristine;
!! build: it's being filled with entries;
!! assembled: ready to use in computations;
!! update: accepts coefficients but only
!! in already existing entries.
!! The transitions among the states are detailed in
!! psb_T_vect_mod.
integer(psb_ipk_), private :: bldstate = psb_vect_null_
integer(psb_ipk_), private :: dupl = psb_dupl_null_
integer(psb_ipk_), private :: ncfs = 0
integer(psb_ipk_), allocatable :: iv(:)
contains
!
! Constructors/allocators
@@ -2637,6 +2649,22 @@ module psb_d_base_multivect_mod
procedure, pass(x) :: zero => d_base_mlv_zero
procedure, pass(x) :: asb => d_base_mlv_asb
procedure, pass(x) :: free => d_base_mlv_free
procedure, pass(x) :: reinit => d_base_mlv_reinit
procedure, pass(x) :: set_ncfs => d_base_mlv_set_ncfs
procedure, pass(x) :: get_ncfs => d_base_mlv_get_ncfs
procedure, pass(x) :: set_dupl => d_base_mlv_set_dupl
procedure, pass(x) :: get_dupl => d_base_mlv_get_dupl
procedure, pass(x) :: set_state => d_base_mlv_set_state
procedure, pass(x) :: set_null => d_base_mlv_set_null
procedure, pass(x) :: set_bld => d_base_mlv_set_bld
procedure, pass(x) :: set_upd => d_base_mlv_set_upd
procedure, pass(x) :: set_asb => d_base_mlv_set_asb
procedure, pass(x) :: get_state => d_base_mlv_get_state
procedure, pass(x) :: is_null => d_base_mlv_is_null
procedure, pass(x) :: is_bld => d_base_mlv_is_bld
procedure, pass(x) :: is_upd => d_base_mlv_is_upd
procedure, pass(x) :: is_asb => d_base_mlv_is_asb
procedure, pass(x) :: base_cpy => d_base_mlv_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -2750,7 +2778,8 @@ contains
integer(psb_ipk_) :: info
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
call this%asb(size(x,dim=1,kind=psb_ipk_),&
& size(x,dim=2,kind=psb_ipk_),info)
end function constructor
@@ -2800,12 +2829,21 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine d_base_mlv_bld_n(x,m,n)
subroutine d_base_mlv_bld_n(x,m,n,scratch)
use psb_realloc_mod
integer(psb_ipk_), intent(in) :: m,n
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info)
@@ -2827,6 +2865,10 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,n,x%v,info)
if (try_newins) then
call psb_realloc(n,x%iv,info)
call x%set_ncfs(0)
end if
end subroutine d_base_mlv_all
@@ -2848,6 +2890,22 @@ contains
end subroutine d_base_mlv_mold
subroutine d_base_mlv_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_base_multivect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%sync()
x%v(:,:) = dzero
call x%set_host()
call x%set_upd()
end if
end subroutine d_base_mlv_reinit
!
! Insert a bunch of values at specified positions.
!
@@ -2875,57 +2933,123 @@ contains
!! \param info return code
!!
!
subroutine d_base_mlv_ins(n,irl,val,dupl,x,info)
subroutine d_base_mlv_ins(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n, dupl,maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
integer(psb_ipk_) :: i, isz, nc, 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,1)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
nc = size(x%v,2)
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_realloc(isz,nc,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)
case(psb_dupl_add_)
else if (x%is_upd()) then
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
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,1)
nc = size(x%v,2)
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 default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i),:) = x%v(irl(i),:) + val(i,:)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v,1)
nc = size(x%v,2)
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
call psb_errpush(info,'base_mlv_vect_ins')
return
@@ -2945,6 +3069,7 @@ contains
class(psb_d_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=dzero
call x%set_host()
end subroutine d_base_mlv_zero
@@ -2963,19 +3088,73 @@ contains
!!
!
subroutine d_base_mlv_asb(m,n, x, info)
subroutine d_base_mlv_asb(m,n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
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()
xvsz = psb_size(x%v)
call psb_realloc(m,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 (any(vv(x%iv(i),:).ne.dzero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i),:) = x%v(i,:)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) &
& call psb_realloc(m,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() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%set_host()
call x%set_asb()
call x%sync()
end subroutine d_base_mlv_asb
@@ -3001,6 +3180,103 @@ contains
end subroutine d_base_mlv_free
function d_base_mlv_get_ncfs(x) result(res)
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function d_base_mlv_get_ncfs
function d_base_mlv_get_dupl(x) result(res)
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function d_base_mlv_get_dupl
function d_base_mlv_get_state(x) result(res)
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function d_base_mlv_get_state
function d_base_mlv_is_null(x) result(res)
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function d_base_mlv_is_null
function d_base_mlv_is_bld(x) result(res)
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function d_base_mlv_is_bld
function d_base_mlv_is_upd(x) result(res)
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function d_base_mlv_is_upd
function d_base_mlv_is_asb(x) result(res)
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function d_base_mlv_is_asb
subroutine d_base_mlv_set_ncfs(n,x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine d_base_mlv_set_ncfs
subroutine d_base_mlv_set_dupl(n,x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine d_base_mlv_set_dupl
subroutine d_base_mlv_set_state(n,x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine d_base_mlv_set_state
subroutine d_base_mlv_set_null(x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine d_base_mlv_set_null
subroutine d_base_mlv_set_bld(x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine d_base_mlv_set_bld
subroutine d_base_mlv_set_upd(x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine d_base_mlv_set_upd
subroutine d_base_mlv_set_asb(x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine d_base_mlv_set_asb
!
@@ -3097,6 +3373,25 @@ contains
res = .true.
end function d_base_mlv_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine d_base_mlv_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
class(psb_d_base_multivect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine d_base_mlv_cpy
!
! Size info.
@@ -3139,7 +3434,7 @@ contains
integer(psb_epk_) :: res
! Force 8-byte integers.
res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols()
res = (1_psb_epk_ * psb_sizeof_dp) * x%get_nrows() * x%get_ncols()
end function d_base_mlv_sizeof
base/modules/serial/psb_d_vect_mod.F90
+3 -3
View File
@@ -1966,11 +1966,11 @@ contains
end subroutine d_mvect_free
subroutine d_mvect_ins(n,irl,val,x,info)
subroutine d_mvect_ins(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n,maxr
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
@@ -1983,7 +1983,7 @@ contains
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
call x%v%ins(n,irl,val,dupl,maxr,info)
end subroutine d_mvect_ins
base/modules/serial/psb_i_base_vect_mod.F90
+353 -58
View File
@@ -330,22 +330,6 @@ contains
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
@@ -364,6 +348,22 @@ contains
end subroutine i_base_mold
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
!
! Insert a bunch of values at specified positions.
!
@@ -424,7 +424,9 @@ contains
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_
@@ -595,7 +597,7 @@ contains
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = izero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
@@ -607,7 +609,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. izero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
@@ -678,7 +680,7 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = izero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
@@ -690,7 +692,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. izero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
@@ -748,8 +750,6 @@ contains
call x%set_null()
end subroutine i_base_free
!
!> Function base_free_buffer:
!! \memberof psb_i_base_vect_type
@@ -1398,6 +1398,18 @@ module psb_i_base_multivect_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
@@ -1416,6 +1428,22 @@ module psb_i_base_multivect_mod
procedure, pass(x) :: zero => i_base_mlv_zero
procedure, pass(x) :: asb => i_base_mlv_asb
procedure, pass(x) :: free => i_base_mlv_free
procedure, pass(x) :: reinit => i_base_mlv_reinit
procedure, pass(x) :: set_ncfs => i_base_mlv_set_ncfs
procedure, pass(x) :: get_ncfs => i_base_mlv_get_ncfs
procedure, pass(x) :: set_dupl => i_base_mlv_set_dupl
procedure, pass(x) :: get_dupl => i_base_mlv_get_dupl
procedure, pass(x) :: set_state => i_base_mlv_set_state
procedure, pass(x) :: set_null => i_base_mlv_set_null
procedure, pass(x) :: set_bld => i_base_mlv_set_bld
procedure, pass(x) :: set_upd => i_base_mlv_set_upd
procedure, pass(x) :: set_asb => i_base_mlv_set_asb
procedure, pass(x) :: get_state => i_base_mlv_get_state
procedure, pass(x) :: is_null => i_base_mlv_is_null
procedure, pass(x) :: is_bld => i_base_mlv_is_bld
procedure, pass(x) :: is_upd => i_base_mlv_is_upd
procedure, pass(x) :: is_asb => i_base_mlv_is_asb
procedure, pass(x) :: base_cpy => i_base_mlv_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -1496,7 +1524,8 @@ contains
integer(psb_ipk_) :: info
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
call this%asb(size(x,dim=1,kind=psb_ipk_),&
& size(x,dim=2,kind=psb_ipk_),info)
end function constructor
@@ -1546,12 +1575,21 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine i_base_mlv_bld_n(x,m,n)
subroutine i_base_mlv_bld_n(x,m,n,scratch)
use psb_realloc_mod
integer(psb_ipk_), intent(in) :: m,n
class(psb_i_base_multivect_type), intent(inout) :: x
integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info)
@@ -1573,6 +1611,10 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,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_mlv_all
@@ -1594,6 +1636,22 @@ contains
end subroutine i_base_mlv_mold
subroutine i_base_mlv_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_base_multivect_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_mlv_reinit
!
! Insert a bunch of values at specified positions.
!
@@ -1621,57 +1679,123 @@ contains
!! \param info return code
!!
!
subroutine i_base_mlv_ins(n,irl,val,dupl,x,info)
subroutine i_base_mlv_ins(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_base_multivect_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, nc, 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,1)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
nc = size(x%v,2)
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_realloc(isz,nc,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)
case(psb_dupl_add_)
else if (x%is_upd()) then
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
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,1)
nc = size(x%v,2)
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 default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i),:) = x%v(irl(i),:) + val(i,:)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v,1)
nc = size(x%v,2)
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
call psb_errpush(info,'base_mlv_vect_ins')
return
@@ -1691,6 +1815,7 @@ contains
class(psb_i_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=izero
call x%set_host()
end subroutine i_base_mlv_zero
@@ -1709,19 +1834,73 @@ contains
!!
!
subroutine i_base_mlv_asb(m,n, x, info)
subroutine i_base_mlv_asb(m,n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_i_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_ipk_), 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()
xvsz = psb_size(x%v)
call psb_realloc(m,n,vv,info)
vv(:,:) = izero
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 (any(vv(x%iv(i),:).ne.izero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i),:) = x%v(i,:)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) &
& call psb_realloc(m,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() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%set_host()
call x%set_asb()
call x%sync()
end subroutine i_base_mlv_asb
@@ -1747,6 +1926,103 @@ contains
end subroutine i_base_mlv_free
function i_base_mlv_get_ncfs(x) result(res)
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function i_base_mlv_get_ncfs
function i_base_mlv_get_dupl(x) result(res)
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function i_base_mlv_get_dupl
function i_base_mlv_get_state(x) result(res)
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function i_base_mlv_get_state
function i_base_mlv_is_null(x) result(res)
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function i_base_mlv_is_null
function i_base_mlv_is_bld(x) result(res)
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function i_base_mlv_is_bld
function i_base_mlv_is_upd(x) result(res)
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function i_base_mlv_is_upd
function i_base_mlv_is_asb(x) result(res)
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function i_base_mlv_is_asb
subroutine i_base_mlv_set_ncfs(n,x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine i_base_mlv_set_ncfs
subroutine i_base_mlv_set_dupl(n,x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine i_base_mlv_set_dupl
subroutine i_base_mlv_set_state(n,x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine i_base_mlv_set_state
subroutine i_base_mlv_set_null(x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine i_base_mlv_set_null
subroutine i_base_mlv_set_bld(x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine i_base_mlv_set_bld
subroutine i_base_mlv_set_upd(x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine i_base_mlv_set_upd
subroutine i_base_mlv_set_asb(x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine i_base_mlv_set_asb
!
@@ -1843,6 +2119,25 @@ contains
res = .true.
end function i_base_mlv_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine i_base_mlv_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
class(psb_i_base_multivect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine i_base_mlv_cpy
!
! Size info.
base/modules/serial/psb_i_vect_mod.F90
+3 -3
View File
@@ -1210,11 +1210,11 @@ contains
end subroutine i_mvect_free
subroutine i_mvect_ins(n,irl,val,x,info)
subroutine i_mvect_ins(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_i_multivect_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
@@ -1227,7 +1227,7 @@ 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_mvect_ins
base/modules/serial/psb_l_base_vect_mod.F90
+354 -59
View File
@@ -331,22 +331,6 @@ contains
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
@@ -365,6 +349,22 @@ contains
end subroutine l_base_mold
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
!
! Insert a bunch of values at specified positions.
!
@@ -425,7 +425,9 @@ contains
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_
@@ -596,7 +598,7 @@ contains
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = lzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
@@ -608,7 +610,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. lzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
@@ -679,7 +681,7 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = lzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
@@ -691,7 +693,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. lzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
@@ -749,8 +751,6 @@ contains
call x%set_null()
end subroutine l_base_free
!
!> Function base_free_buffer:
!! \memberof psb_l_base_vect_type
@@ -1399,6 +1399,18 @@ module psb_l_base_multivect_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
@@ -1417,6 +1429,22 @@ module psb_l_base_multivect_mod
procedure, pass(x) :: zero => l_base_mlv_zero
procedure, pass(x) :: asb => l_base_mlv_asb
procedure, pass(x) :: free => l_base_mlv_free
procedure, pass(x) :: reinit => l_base_mlv_reinit
procedure, pass(x) :: set_ncfs => l_base_mlv_set_ncfs
procedure, pass(x) :: get_ncfs => l_base_mlv_get_ncfs
procedure, pass(x) :: set_dupl => l_base_mlv_set_dupl
procedure, pass(x) :: get_dupl => l_base_mlv_get_dupl
procedure, pass(x) :: set_state => l_base_mlv_set_state
procedure, pass(x) :: set_null => l_base_mlv_set_null
procedure, pass(x) :: set_bld => l_base_mlv_set_bld
procedure, pass(x) :: set_upd => l_base_mlv_set_upd
procedure, pass(x) :: set_asb => l_base_mlv_set_asb
procedure, pass(x) :: get_state => l_base_mlv_get_state
procedure, pass(x) :: is_null => l_base_mlv_is_null
procedure, pass(x) :: is_bld => l_base_mlv_is_bld
procedure, pass(x) :: is_upd => l_base_mlv_is_upd
procedure, pass(x) :: is_asb => l_base_mlv_is_asb
procedure, pass(x) :: base_cpy => l_base_mlv_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -1497,7 +1525,8 @@ contains
integer(psb_ipk_) :: info
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
call this%asb(size(x,dim=1,kind=psb_ipk_),&
& size(x,dim=2,kind=psb_ipk_),info)
end function constructor
@@ -1547,12 +1576,21 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine l_base_mlv_bld_n(x,m,n)
subroutine l_base_mlv_bld_n(x,m,n,scratch)
use psb_realloc_mod
integer(psb_ipk_), intent(in) :: m,n
class(psb_l_base_multivect_type), intent(inout) :: x
integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info)
@@ -1574,6 +1612,10 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,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_mlv_all
@@ -1595,6 +1637,22 @@ contains
end subroutine l_base_mlv_mold
subroutine l_base_mlv_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_l_base_multivect_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_mlv_reinit
!
! Insert a bunch of values at specified positions.
!
@@ -1622,57 +1680,123 @@ contains
!! \param info return code
!!
!
subroutine l_base_mlv_ins(n,irl,val,dupl,x,info)
subroutine l_base_mlv_ins(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_base_multivect_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, nc, 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,1)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
nc = size(x%v,2)
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_realloc(isz,nc,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)
case(psb_dupl_add_)
else if (x%is_upd()) then
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
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,1)
nc = size(x%v,2)
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 default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i),:) = x%v(irl(i),:) + val(i,:)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v,1)
nc = size(x%v,2)
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
call psb_errpush(info,'base_mlv_vect_ins')
return
@@ -1692,6 +1816,7 @@ contains
class(psb_l_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=lzero
call x%set_host()
end subroutine l_base_mlv_zero
@@ -1710,19 +1835,73 @@ contains
!!
!
subroutine l_base_mlv_asb(m,n, x, info)
subroutine l_base_mlv_asb(m,n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_l_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
integer(psb_lpk_), 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()
xvsz = psb_size(x%v)
call psb_realloc(m,n,vv,info)
vv(:,:) = lzero
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 (any(vv(x%iv(i),:).ne.lzero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i),:) = x%v(i,:)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) &
& call psb_realloc(m,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() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%set_host()
call x%set_asb()
call x%sync()
end subroutine l_base_mlv_asb
@@ -1748,6 +1927,103 @@ contains
end subroutine l_base_mlv_free
function l_base_mlv_get_ncfs(x) result(res)
implicit none
class(psb_l_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function l_base_mlv_get_ncfs
function l_base_mlv_get_dupl(x) result(res)
implicit none
class(psb_l_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function l_base_mlv_get_dupl
function l_base_mlv_get_state(x) result(res)
implicit none
class(psb_l_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function l_base_mlv_get_state
function l_base_mlv_is_null(x) result(res)
implicit none
class(psb_l_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function l_base_mlv_is_null
function l_base_mlv_is_bld(x) result(res)
implicit none
class(psb_l_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function l_base_mlv_is_bld
function l_base_mlv_is_upd(x) result(res)
implicit none
class(psb_l_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function l_base_mlv_is_upd
function l_base_mlv_is_asb(x) result(res)
implicit none
class(psb_l_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function l_base_mlv_is_asb
subroutine l_base_mlv_set_ncfs(n,x)
implicit none
class(psb_l_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine l_base_mlv_set_ncfs
subroutine l_base_mlv_set_dupl(n,x)
implicit none
class(psb_l_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine l_base_mlv_set_dupl
subroutine l_base_mlv_set_state(n,x)
implicit none
class(psb_l_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine l_base_mlv_set_state
subroutine l_base_mlv_set_null(x)
implicit none
class(psb_l_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine l_base_mlv_set_null
subroutine l_base_mlv_set_bld(x)
implicit none
class(psb_l_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine l_base_mlv_set_bld
subroutine l_base_mlv_set_upd(x)
implicit none
class(psb_l_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine l_base_mlv_set_upd
subroutine l_base_mlv_set_asb(x)
implicit none
class(psb_l_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine l_base_mlv_set_asb
!
@@ -1844,6 +2120,25 @@ contains
res = .true.
end function l_base_mlv_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine l_base_mlv_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_l_base_multivect_type), intent(in) :: x
class(psb_l_base_multivect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine l_base_mlv_cpy
!
! Size info.
@@ -1886,7 +2181,7 @@ contains
integer(psb_epk_) :: res
! Force 8-byte integers.
res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols()
res = (1_psb_epk_ * psb_sizeof_lp) * x%get_nrows() * x%get_ncols()
end function l_base_mlv_sizeof
base/modules/serial/psb_l_vect_mod.F90
+3 -3
View File
@@ -1211,11 +1211,11 @@ contains
end subroutine l_mvect_free
subroutine l_mvect_ins(n,irl,val,x,info)
subroutine l_mvect_ins(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_l_multivect_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
@@ -1228,7 +1228,7 @@ 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_mvect_ins
base/modules/serial/psb_s_base_vect_mod.F90
+354 -59
View File
@@ -404,22 +404,6 @@ contains
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
@@ -438,6 +422,22 @@ contains
end subroutine s_base_mold
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
!
! Insert a bunch of values at specified positions.
!
@@ -498,7 +498,9 @@ contains
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_
@@ -669,7 +671,7 @@ contains
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = szero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
@@ -681,7 +683,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. szero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
@@ -752,7 +754,7 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = szero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
@@ -764,7 +766,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. szero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
@@ -822,8 +824,6 @@ contains
call x%set_null()
end subroutine s_base_free
!
!> Function base_free_buffer:
!! \memberof psb_s_base_vect_type
@@ -2619,6 +2619,18 @@ module psb_s_base_multivect_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
@@ -2637,6 +2649,22 @@ module psb_s_base_multivect_mod
procedure, pass(x) :: zero => s_base_mlv_zero
procedure, pass(x) :: asb => s_base_mlv_asb
procedure, pass(x) :: free => s_base_mlv_free
procedure, pass(x) :: reinit => s_base_mlv_reinit
procedure, pass(x) :: set_ncfs => s_base_mlv_set_ncfs
procedure, pass(x) :: get_ncfs => s_base_mlv_get_ncfs
procedure, pass(x) :: set_dupl => s_base_mlv_set_dupl
procedure, pass(x) :: get_dupl => s_base_mlv_get_dupl
procedure, pass(x) :: set_state => s_base_mlv_set_state
procedure, pass(x) :: set_null => s_base_mlv_set_null
procedure, pass(x) :: set_bld => s_base_mlv_set_bld
procedure, pass(x) :: set_upd => s_base_mlv_set_upd
procedure, pass(x) :: set_asb => s_base_mlv_set_asb
procedure, pass(x) :: get_state => s_base_mlv_get_state
procedure, pass(x) :: is_null => s_base_mlv_is_null
procedure, pass(x) :: is_bld => s_base_mlv_is_bld
procedure, pass(x) :: is_upd => s_base_mlv_is_upd
procedure, pass(x) :: is_asb => s_base_mlv_is_asb
procedure, pass(x) :: base_cpy => s_base_mlv_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -2750,7 +2778,8 @@ contains
integer(psb_ipk_) :: info
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
call this%asb(size(x,dim=1,kind=psb_ipk_),&
& size(x,dim=2,kind=psb_ipk_),info)
end function constructor
@@ -2800,12 +2829,21 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine s_base_mlv_bld_n(x,m,n)
subroutine s_base_mlv_bld_n(x,m,n,scratch)
use psb_realloc_mod
integer(psb_ipk_), intent(in) :: m,n
class(psb_s_base_multivect_type), intent(inout) :: x
integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info)
@@ -2827,6 +2865,10 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,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_mlv_all
@@ -2848,6 +2890,22 @@ contains
end subroutine s_base_mlv_mold
subroutine s_base_mlv_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_s_base_multivect_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_mlv_reinit
!
! Insert a bunch of values at specified positions.
!
@@ -2875,57 +2933,123 @@ contains
!! \param info return code
!!
!
subroutine s_base_mlv_ins(n,irl,val,dupl,x,info)
subroutine s_base_mlv_ins(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_base_multivect_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, nc, 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,1)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
nc = size(x%v,2)
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_realloc(isz,nc,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)
case(psb_dupl_add_)
else if (x%is_upd()) then
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
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,1)
nc = size(x%v,2)
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 default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i),:) = x%v(irl(i),:) + val(i,:)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v,1)
nc = size(x%v,2)
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
call psb_errpush(info,'base_mlv_vect_ins')
return
@@ -2945,6 +3069,7 @@ contains
class(psb_s_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=szero
call x%set_host()
end subroutine s_base_mlv_zero
@@ -2963,19 +3088,73 @@ contains
!!
!
subroutine s_base_mlv_asb(m,n, x, info)
subroutine s_base_mlv_asb(m,n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_s_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
real(psb_spk_), 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()
xvsz = psb_size(x%v)
call psb_realloc(m,n,vv,info)
vv(:,:) = szero
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 (any(vv(x%iv(i),:).ne.szero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i),:) = x%v(i,:)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) &
& call psb_realloc(m,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() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%set_host()
call x%set_asb()
call x%sync()
end subroutine s_base_mlv_asb
@@ -3001,6 +3180,103 @@ contains
end subroutine s_base_mlv_free
function s_base_mlv_get_ncfs(x) result(res)
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function s_base_mlv_get_ncfs
function s_base_mlv_get_dupl(x) result(res)
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function s_base_mlv_get_dupl
function s_base_mlv_get_state(x) result(res)
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function s_base_mlv_get_state
function s_base_mlv_is_null(x) result(res)
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function s_base_mlv_is_null
function s_base_mlv_is_bld(x) result(res)
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function s_base_mlv_is_bld
function s_base_mlv_is_upd(x) result(res)
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function s_base_mlv_is_upd
function s_base_mlv_is_asb(x) result(res)
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function s_base_mlv_is_asb
subroutine s_base_mlv_set_ncfs(n,x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine s_base_mlv_set_ncfs
subroutine s_base_mlv_set_dupl(n,x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine s_base_mlv_set_dupl
subroutine s_base_mlv_set_state(n,x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine s_base_mlv_set_state
subroutine s_base_mlv_set_null(x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine s_base_mlv_set_null
subroutine s_base_mlv_set_bld(x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine s_base_mlv_set_bld
subroutine s_base_mlv_set_upd(x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine s_base_mlv_set_upd
subroutine s_base_mlv_set_asb(x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine s_base_mlv_set_asb
!
@@ -3097,6 +3373,25 @@ contains
res = .true.
end function s_base_mlv_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine s_base_mlv_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
class(psb_s_base_multivect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine s_base_mlv_cpy
!
! Size info.
@@ -3139,7 +3434,7 @@ contains
integer(psb_epk_) :: res
! Force 8-byte integers.
res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols()
res = (1_psb_epk_ * psb_sizeof_sp) * x%get_nrows() * x%get_ncols()
end function s_base_mlv_sizeof
base/modules/serial/psb_s_vect_mod.F90
+3 -3
View File
@@ -1966,11 +1966,11 @@ contains
end subroutine s_mvect_free
subroutine s_mvect_ins(n,irl,val,x,info)
subroutine s_mvect_ins(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_s_multivect_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
@@ -1983,7 +1983,7 @@ 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_mvect_ins
base/modules/serial/psb_z_base_vect_mod.F90
+354 -59
View File
@@ -397,22 +397,6 @@ contains
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
@@ -431,6 +415,22 @@ contains
end subroutine z_base_mold
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
!
! Insert a bunch of values at specified positions.
!
@@ -491,7 +491,9 @@ contains
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_
@@ -662,7 +664,7 @@ contains
ncfs = x%get_ncfs()
xvsz = psb_size(x%v)
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = zzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,ncfs
@@ -674,7 +676,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,ncfs
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. zzero) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
@@ -745,7 +747,7 @@ contains
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled')
if (x%is_bld()) then
call psb_realloc(n,vv,info)
vv(:) = dzero
vv(:) = zzero
select case(x%get_dupl())
case(psb_dupl_add_)
do i=1,x%get_ncfs()
@@ -757,7 +759,7 @@ contains
end do
case(psb_dupl_err_)
do i=1,x%get_ncfs()
if (vv(x%iv(i)).ne.dzero) then
if (vv(x%iv(i)).ne. zzero) then
call psb_errpush(psb_err_duplicate_coo,'vect_asb')
return
else
@@ -815,8 +817,6 @@ contains
call x%set_null()
end subroutine z_base_free
!
!> Function base_free_buffer:
!! \memberof psb_z_base_vect_type
@@ -2440,6 +2440,18 @@ module psb_z_base_multivect_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
@@ -2458,6 +2470,22 @@ module psb_z_base_multivect_mod
procedure, pass(x) :: zero => z_base_mlv_zero
procedure, pass(x) :: asb => z_base_mlv_asb
procedure, pass(x) :: free => z_base_mlv_free
procedure, pass(x) :: reinit => z_base_mlv_reinit
procedure, pass(x) :: set_ncfs => z_base_mlv_set_ncfs
procedure, pass(x) :: get_ncfs => z_base_mlv_get_ncfs
procedure, pass(x) :: set_dupl => z_base_mlv_set_dupl
procedure, pass(x) :: get_dupl => z_base_mlv_get_dupl
procedure, pass(x) :: set_state => z_base_mlv_set_state
procedure, pass(x) :: set_null => z_base_mlv_set_null
procedure, pass(x) :: set_bld => z_base_mlv_set_bld
procedure, pass(x) :: set_upd => z_base_mlv_set_upd
procedure, pass(x) :: set_asb => z_base_mlv_set_asb
procedure, pass(x) :: get_state => z_base_mlv_get_state
procedure, pass(x) :: is_null => z_base_mlv_is_null
procedure, pass(x) :: is_bld => z_base_mlv_is_bld
procedure, pass(x) :: is_upd => z_base_mlv_is_upd
procedure, pass(x) :: is_asb => z_base_mlv_is_asb
procedure, pass(x) :: base_cpy => z_base_mlv_cpy
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
@@ -2571,7 +2599,8 @@ contains
integer(psb_ipk_) :: info
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
call this%asb(size(x,dim=1,kind=psb_ipk_),&
& size(x,dim=2,kind=psb_ipk_),info)
end function constructor
@@ -2621,12 +2650,21 @@ contains
!! \brief Build method with size (uninitialized data)
!! \param n size to be allocated.
!!
subroutine z_base_mlv_bld_n(x,m,n)
subroutine z_base_mlv_bld_n(x,m,n,scratch)
use psb_realloc_mod
integer(psb_ipk_), intent(in) :: m,n
class(psb_z_base_multivect_type), intent(inout) :: x
integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
logical :: scratch_
if (present(scratch)) then
scratch_ = scratch
else
scratch_ = .false.
end if
call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info)
@@ -2648,6 +2686,10 @@ contains
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,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_mlv_all
@@ -2669,6 +2711,22 @@ contains
end subroutine z_base_mlv_mold
subroutine z_base_mlv_reinit(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_z_base_multivect_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_mlv_reinit
!
! Insert a bunch of values at specified positions.
!
@@ -2696,57 +2754,123 @@ contains
!! \param info return code
!!
!
subroutine z_base_mlv_ins(n,irl,val,dupl,x,info)
subroutine z_base_mlv_ins(n,irl,val,dupl,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_base_multivect_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, nc, 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,1)
select case(dupl)
case(psb_dupl_ovwrt_)
if (try_newins) then
if (x%is_bld()) then
nc = size(x%v,2)
ncfs_ = x%get_ncfs()
isz = ncfs_ + n
call psb_realloc(isz,nc,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)
case(psb_dupl_add_)
else if (x%is_upd()) then
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
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,1)
nc = size(x%v,2)
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 default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if ((1 <= irl(i)).and.(irl(i) <= maxr)) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i),:) = x%v(irl(i),:) + val(i,:)
end if
enddo
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
else
info = psb_err_invalid_vect_state_
end if
else
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
isz = size(x%v,1)
nc = size(x%v,2)
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
call psb_errpush(info,'base_mlv_vect_ins')
return
@@ -2766,6 +2890,7 @@ contains
class(psb_z_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=zzero
call x%set_host()
end subroutine z_base_mlv_zero
@@ -2784,19 +2909,73 @@ contains
!!
!
subroutine z_base_mlv_asb(m,n, x, info)
subroutine z_base_mlv_asb(m,n, x, info, scratch)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_z_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
logical :: scratch_
integer(psb_ipk_) :: i, ncfs, xvsz
complex(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()
xvsz = psb_size(x%v)
call psb_realloc(m,n,vv,info)
vv(:,:) = zzero
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 (any(vv(x%iv(i),:).ne.zzero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb')
return
else
vv(x%iv(i),:) = x%v(i,:)
end if
end do
case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl()
info =-7
end select
call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) &
& call psb_realloc(m,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() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end if
call x%set_host()
call x%set_asb()
call x%sync()
end subroutine z_base_mlv_asb
@@ -2822,6 +3001,103 @@ contains
end subroutine z_base_mlv_free
function z_base_mlv_get_ncfs(x) result(res)
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%ncfs
end function z_base_mlv_get_ncfs
function z_base_mlv_get_dupl(x) result(res)
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function z_base_mlv_get_dupl
function z_base_mlv_get_state(x) result(res)
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%bldstate
end function z_base_mlv_get_state
function z_base_mlv_is_null(x) result(res)
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_null_)
end function z_base_mlv_is_null
function z_base_mlv_is_bld(x) result(res)
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_bld_)
end function z_base_mlv_is_bld
function z_base_mlv_is_upd(x) result(res)
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_upd_)
end function z_base_mlv_is_upd
function z_base_mlv_is_asb(x) result(res)
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
logical :: res
res = (x%bldstate == psb_vect_asb_)
end function z_base_mlv_is_asb
subroutine z_base_mlv_set_ncfs(n,x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%ncfs = n
end subroutine z_base_mlv_set_ncfs
subroutine z_base_mlv_set_dupl(n,x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%dupl = n
end subroutine z_base_mlv_set_dupl
subroutine z_base_mlv_set_state(n,x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
x%bldstate = n
end subroutine z_base_mlv_set_state
subroutine z_base_mlv_set_null(x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_null_
end subroutine z_base_mlv_set_null
subroutine z_base_mlv_set_bld(x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_bld_
end subroutine z_base_mlv_set_bld
subroutine z_base_mlv_set_upd(x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_upd_
end subroutine z_base_mlv_set_upd
subroutine z_base_mlv_set_asb(x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
x%bldstate = psb_vect_asb_
end subroutine z_base_mlv_set_asb
!
@@ -2918,6 +3194,25 @@ contains
res = .true.
end function z_base_mlv_is_sync
!> Function base_cpy:
!! \memberof psb_d_base_vect_type
!! \brief base_cpy: copy base contents
!! \param y returned variable
!!
subroutine z_base_mlv_cpy(x, y)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
class(psb_z_base_multivect_type), intent(out) :: y
if (allocated(x%v)) call y%bld(x%v)
call y%set_state(x%get_state())
call y%set_dupl(x%get_dupl())
call y%set_ncfs(x%get_ncfs())
if (allocated(x%iv)) y%iv = x%iv
end subroutine z_base_mlv_cpy
!
! Size info.
@@ -2960,7 +3255,7 @@ contains
integer(psb_epk_) :: res
! Force 8-byte integers.
res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols()
res = (1_psb_epk_ * (2*psb_sizeof_dp)) * x%get_nrows() * x%get_ncols()
end function z_base_mlv_sizeof
base/modules/serial/psb_z_vect_mod.F90
+3 -3
View File
@@ -1887,11 +1887,11 @@ contains
end subroutine z_mvect_free
subroutine z_mvect_ins(n,irl,val,x,info)
subroutine z_mvect_ins(n,irl,val,x,maxr,info)
use psi_serial_mod
implicit none
class(psb_z_multivect_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
@@ -1904,7 +1904,7 @@ 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_mvect_ins
base/modules/tools/psb_c_tools_mod.F90
+2 -1
View File
@@ -80,7 +80,7 @@ Module psb_c_tools_mod
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)
subroutine psb_casb_vect_r2(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -88,6 +88,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_r2
subroutine psb_casb_multivect(x, desc_a, info,mold, scratch, n)
import
base/modules/tools/psb_d_tools_mod.F90
+2 -1
View File
@@ -80,7 +80,7 @@ Module psb_d_tools_mod
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dasb_vect
subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch)
subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -88,6 +88,7 @@ Module psb_d_tools_mod
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dasb_vect_r2
subroutine psb_dasb_multivect(x, desc_a, info,mold, scratch, n)
import
base/modules/tools/psb_i_tools_mod.F90
+2 -1
View File
@@ -79,7 +79,7 @@ Module psb_i_tools_mod
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)
subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -87,6 +87,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_r2
subroutine psb_iasb_multivect(x, desc_a, info,mold, scratch, n)
import
base/modules/tools/psb_l_tools_mod.F90
+2 -1
View File
@@ -79,7 +79,7 @@ Module psb_l_tools_mod
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)
subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -87,6 +87,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_r2
subroutine psb_lasb_multivect(x, desc_a, info,mold, scratch, n)
import
base/modules/tools/psb_s_tools_mod.F90
+2 -1
View File
@@ -80,7 +80,7 @@ Module psb_s_tools_mod
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)
subroutine psb_sasb_vect_r2(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -88,6 +88,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_r2
subroutine psb_sasb_multivect(x, desc_a, info,mold, scratch, n)
import
base/modules/tools/psb_z_tools_mod.F90
+2 -1
View File
@@ -80,7 +80,7 @@ Module psb_z_tools_mod
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)
subroutine psb_zasb_vect_r2(x, desc_a, info,mold, scratch,dupl)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -88,6 +88,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_r2
subroutine psb_zasb_multivect(x, desc_a, info,mold, scratch, n)
import