fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-17 03:12:15 +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
base/tools/psb_callc.f90
+2 -40
View File
@@ -207,48 +207,11 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
goto 9999
endif
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (desc_a%is_asb().or.desc_a%is_upd()) then
nr = max(1,desc_a%get_local_cols())
else if (desc_a%is_bld()) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid desc_a')
goto 9999
endif
allocate(x(lb_:lb_+n_-1), stat=info)
if (info == 0) then
do i=lb_, lb_+n_-1
allocate(psb_c_base_vect_type :: x(i)%v, stat=info)
if (info == 0) call x(i)%all(nr,info)
if (info == 0) call x(i)%zero()
if (info /= 0) exit
end do
end if
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
do i=lb_, lb_+n_-1
call x(i)%set_dupl(dupl_)
call x(i)%set_remote_build(bldmode_)
if (x(i)%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x(i)%rmtv(nrmt_))
end if
call psb_geall(x(i),desc_a,info,dupl, bldmode)
end do
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@@ -261,7 +224,6 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_calloc_vect_r2
base/tools/psb_casb.f90
+6 -32
View File
@@ -188,7 +188,7 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch, 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)
use psb_base_mod, psb_protect_name => psb_casb_vect_r2
implicit none
@@ -197,12 +197,12 @@ subroutine psb_casb_vect_r2(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
integer(psb_ipk_) :: np,me, i, n
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_
logical :: scratch_
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -217,8 +217,6 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
@@ -230,35 +228,11 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
n = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
do i=1, n
call psb_geasb(x(i),desc_a,info, mold, scratch, dupl)
end do
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
call x(i)%cnv(mold)
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
base/tools/psb_cins.f90
+1 -1
View File
@@ -475,7 +475,7 @@ subroutine psb_cins_multivect(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
base/tools/psb_dallc.f90
+2 -40
View File
@@ -207,48 +207,11 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
goto 9999
endif
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (desc_a%is_asb().or.desc_a%is_upd()) then
nr = max(1,desc_a%get_local_cols())
else if (desc_a%is_bld()) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid desc_a')
goto 9999
endif
allocate(x(lb_:lb_+n_-1), stat=info)
if (info == 0) then
do i=lb_, lb_+n_-1
allocate(psb_d_base_vect_type :: x(i)%v, stat=info)
if (info == 0) call x(i)%all(nr,info)
if (info == 0) call x(i)%zero()
if (info /= 0) exit
end do
end if
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
do i=lb_, lb_+n_-1
call x(i)%set_dupl(dupl_)
call x(i)%set_remote_build(bldmode_)
if (x(i)%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x(i)%rmtv(nrmt_))
end if
call psb_geall(x(i),desc_a,info,dupl, bldmode)
end do
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@@ -261,7 +224,6 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_dalloc_vect_r2
base/tools/psb_dasb.f90
+6 -32
View File
@@ -188,7 +188,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch, 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)
use psb_base_mod, psb_protect_name => psb_dasb_vect_r2
implicit none
@@ -197,12 +197,12 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
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
! local variables
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, i, n
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_
logical :: scratch_
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -217,8 +217,6 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
@@ -230,35 +228,11 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
n = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
do i=1, n
call psb_geasb(x(i),desc_a,info, mold, scratch, dupl)
end do
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
call x(i)%cnv(mold)
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
base/tools/psb_dins.f90
+1 -1
View File
@@ -475,7 +475,7 @@ subroutine psb_dins_multivect(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
base/tools/psb_iallc.f90
+2 -40
View File
@@ -207,48 +207,11 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
goto 9999
endif
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (desc_a%is_asb().or.desc_a%is_upd()) then
nr = max(1,desc_a%get_local_cols())
else if (desc_a%is_bld()) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid desc_a')
goto 9999
endif
allocate(x(lb_:lb_+n_-1), stat=info)
if (info == 0) then
do i=lb_, lb_+n_-1
allocate(psb_i_base_vect_type :: x(i)%v, stat=info)
if (info == 0) call x(i)%all(nr,info)
if (info == 0) call x(i)%zero()
if (info /= 0) exit
end do
end if
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
do i=lb_, lb_+n_-1
call x(i)%set_dupl(dupl_)
call x(i)%set_remote_build(bldmode_)
if (x(i)%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x(i)%rmtv(nrmt_))
end if
call psb_geall(x(i),desc_a,info,dupl, bldmode)
end do
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@@ -261,7 +224,6 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_ialloc_vect_r2
base/tools/psb_iasb.f90
+6 -32
View File
@@ -188,7 +188,7 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch, 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)
use psb_base_mod, psb_protect_name => psb_iasb_vect_r2
implicit none
@@ -197,12 +197,12 @@ subroutine psb_iasb_vect_r2(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
integer(psb_ipk_) :: np,me, i, n
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_
logical :: scratch_
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -217,8 +217,6 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
@@ -230,35 +228,11 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch)
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
n = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
do i=1, n
call psb_geasb(x(i),desc_a,info, mold, scratch, dupl)
end do
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
call x(i)%cnv(mold)
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
base/tools/psb_iins.f90
+1 -1
View File
@@ -475,7 +475,7 @@ subroutine psb_iins_multivect(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
base/tools/psb_lallc.f90
+2 -40
View File
@@ -207,48 +207,11 @@ subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
goto 9999
endif
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (desc_a%is_asb().or.desc_a%is_upd()) then
nr = max(1,desc_a%get_local_cols())
else if (desc_a%is_bld()) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid desc_a')
goto 9999
endif
allocate(x(lb_:lb_+n_-1), stat=info)
if (info == 0) then
do i=lb_, lb_+n_-1
allocate(psb_l_base_vect_type :: x(i)%v, stat=info)
if (info == 0) call x(i)%all(nr,info)
if (info == 0) call x(i)%zero()
if (info /= 0) exit
end do
end if
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
do i=lb_, lb_+n_-1
call x(i)%set_dupl(dupl_)
call x(i)%set_remote_build(bldmode_)
if (x(i)%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x(i)%rmtv(nrmt_))
end if
call psb_geall(x(i),desc_a,info,dupl, bldmode)
end do
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@@ -261,7 +224,6 @@ subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_lalloc_vect_r2
base/tools/psb_lasb.f90
+6 -32
View File
@@ -188,7 +188,7 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch, 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)
use psb_base_mod, psb_protect_name => psb_lasb_vect_r2
implicit none
@@ -197,12 +197,12 @@ subroutine psb_lasb_vect_r2(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
integer(psb_ipk_) :: np,me, i, n
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_
logical :: scratch_
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -217,8 +217,6 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
@@ -230,35 +228,11 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch)
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
n = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
do i=1, n
call psb_geasb(x(i),desc_a,info, mold, scratch, dupl)
end do
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
call x(i)%cnv(mold)
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
base/tools/psb_lins.f90
+1 -1
View File
@@ -475,7 +475,7 @@ subroutine psb_lins_multivect(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
base/tools/psb_sallc.f90
+2 -40
View File
@@ -207,48 +207,11 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
goto 9999
endif
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (desc_a%is_asb().or.desc_a%is_upd()) then
nr = max(1,desc_a%get_local_cols())
else if (desc_a%is_bld()) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid desc_a')
goto 9999
endif
allocate(x(lb_:lb_+n_-1), stat=info)
if (info == 0) then
do i=lb_, lb_+n_-1
allocate(psb_s_base_vect_type :: x(i)%v, stat=info)
if (info == 0) call x(i)%all(nr,info)
if (info == 0) call x(i)%zero()
if (info /= 0) exit
end do
end if
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
do i=lb_, lb_+n_-1
call x(i)%set_dupl(dupl_)
call x(i)%set_remote_build(bldmode_)
if (x(i)%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x(i)%rmtv(nrmt_))
end if
call psb_geall(x(i),desc_a,info,dupl, bldmode)
end do
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@@ -261,7 +224,6 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_salloc_vect_r2
base/tools/psb_sasb.f90
+6 -32
View File
@@ -188,7 +188,7 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch, 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)
use psb_base_mod, psb_protect_name => psb_sasb_vect_r2
implicit none
@@ -197,12 +197,12 @@ subroutine psb_sasb_vect_r2(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
integer(psb_ipk_) :: np,me, i, n
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_
logical :: scratch_
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -217,8 +217,6 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
@@ -230,35 +228,11 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch)
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
n = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
do i=1, n
call psb_geasb(x(i),desc_a,info, mold, scratch, dupl)
end do
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
call x(i)%cnv(mold)
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
base/tools/psb_sins.f90
+1 -1
View File
@@ -475,7 +475,7 @@ subroutine psb_sins_multivect(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
base/tools/psb_zallc.f90
+2 -40
View File
@@ -207,48 +207,11 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
goto 9999
endif
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (desc_a%is_asb().or.desc_a%is_upd()) then
nr = max(1,desc_a%get_local_cols())
else if (desc_a%is_bld()) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid desc_a')
goto 9999
endif
allocate(x(lb_:lb_+n_-1), stat=info)
if (info == 0) then
do i=lb_, lb_+n_-1
allocate(psb_z_base_vect_type :: x(i)%v, stat=info)
if (info == 0) call x(i)%all(nr,info)
if (info == 0) call x(i)%zero()
if (info /= 0) exit
end do
end if
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
do i=lb_, lb_+n_-1
call x(i)%set_dupl(dupl_)
call x(i)%set_remote_build(bldmode_)
if (x(i)%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x(i)%rmtv(nrmt_))
end if
call psb_geall(x(i),desc_a,info,dupl, bldmode)
end do
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@@ -261,7 +224,6 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_zalloc_vect_r2
base/tools/psb_zasb.f90
+6 -32
View File
@@ -188,7 +188,7 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch, 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)
use psb_base_mod, psb_protect_name => psb_zasb_vect_r2
implicit none
@@ -197,12 +197,12 @@ subroutine psb_zasb_vect_r2(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
integer(psb_ipk_) :: np,me, i, n
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_
logical :: scratch_
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -217,8 +217,6 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
@@ -230,35 +228,11 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch)
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
n = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
do i=1, n
call psb_geasb(x(i),desc_a,info, mold, scratch, dupl)
end do
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info,scratch=scratch)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
call x(i)%cnv(mold)
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
base/tools/psb_zins.f90
+1 -1
View File
@@ -475,7 +475,7 @@ subroutine psb_zins_multivect(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