mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-15 10:29:10 +00:00
psblas3-matasb:
base/modules/Makefile base/modules/psb_d_base_vect_mod.f90 base/modules/psb_d_mat_mod.f90 base/modules/psb_d_tools_mod.f90 base/modules/psb_d_vect_mod.F90 base/modules/psb_i_base_vect_mod.f90 base/modules/psb_i_vect_mod.F90 base/modules/psb_vect_mod.f90 base/serial/impl/psb_d_base_mat_impl.F90 base/serial/impl/psb_d_mat_impl.F90 base/tools/psb_dspins.f90 csputs with encapsulatd vectors. Defined encapsulated multivectors.
This commit is contained in:
Salvatore Filippone
@@ -67,7 +67,7 @@ psb_z_base_mat_mod.o: psb_z_base_vect_mod.o
|
||||
psb_c_base_vect_mod.o psb_s_base_vect_mod.o psb_d_base_vect_mod.o psb_z_base_vect_mod.o: psb_i_base_vect_mod.o
|
||||
psb_i_base_vect_mod.o psb_c_base_vect_mod.o psb_s_base_vect_mod.o psb_d_base_vect_mod.o psb_z_base_vect_mod.o: psi_serial_mod.o psb_realloc_mod.o
|
||||
psb_s_mat_mod.o: psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_s_csc_mat_mod.o psb_s_vect_mod.o
|
||||
psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o psb_d_csc_mat_mod.o psb_d_vect_mod.o
|
||||
psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o psb_d_csc_mat_mod.o psb_d_vect_mod.o psb_i_vect_mod.o
|
||||
psb_c_mat_mod.o: psb_c_base_mat_mod.o psb_c_csr_mat_mod.o psb_c_csc_mat_mod.o psb_c_vect_mod.o
|
||||
psb_z_mat_mod.o: psb_z_base_mat_mod.o psb_z_csr_mat_mod.o psb_z_csc_mat_mod.o psb_z_vect_mod.o
|
||||
psb_s_csc_mat_mod.o psb_s_csr_mat_mod.o: psb_s_base_mat_mod.o
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -119,7 +119,9 @@ module psb_d_mat_mod
|
||||
procedure, pass(a) :: csall => psb_d_csall
|
||||
procedure, pass(a) :: free => psb_d_free
|
||||
procedure, pass(a) :: trim => psb_d_trim
|
||||
procedure, pass(a) :: csput => psb_d_csput
|
||||
procedure, pass(a) :: csput_a => psb_d_csput_a
|
||||
procedure, pass(a) :: csput_v => psb_d_csput_v
|
||||
generic, public :: csput => csput_a, csput_v
|
||||
procedure, pass(a) :: csgetptn => psb_d_csgetptn
|
||||
procedure, pass(a) :: csgetrow => psb_d_csgetrow
|
||||
procedure, pass(a) :: csgetblk => psb_d_csgetblk
|
||||
@@ -379,14 +381,28 @@ module psb_d_mat_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
import :: psb_ipk_, psb_dspmat_type, psb_dpk_
|
||||
class(psb_dspmat_type), intent(inout) :: a
|
||||
real(psb_dpk_), intent(in) :: val(:)
|
||||
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: gtl(:)
|
||||
end subroutine psb_d_csput
|
||||
end subroutine psb_d_csput_a
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
use psb_d_vect_mod, only : psb_d_vect_type
|
||||
use psb_i_vect_mod, only : psb_i_vect_type
|
||||
import :: psb_ipk_, psb_dspmat_type, psb_dpk_
|
||||
class(psb_dspmat_type), intent(inout) :: a
|
||||
type(psb_d_vect_type), intent(inout) :: val
|
||||
type(psb_i_vect_type), intent(inout) :: ia, ja
|
||||
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: gtl(:)
|
||||
end subroutine psb_d_csput_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
|
||||
@@ -286,6 +286,20 @@ Module psb_d_tools_mod
|
||||
logical, intent(in), optional :: rebuild
|
||||
logical, intent(in), optional :: local
|
||||
end subroutine psb_dspins
|
||||
subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
|
||||
use psb_i_vect_mod, only : psb_i_vect_type
|
||||
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
|
||||
& psb_d_base_vect_type, psb_d_vect_type,&
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
type(psb_dspmat_type), intent(inout) :: a
|
||||
integer(psb_ipk_), intent(in) :: nz
|
||||
type(psb_i_vect_type), intent(inout) :: ia,ja
|
||||
type(psb_d_vect_type), intent(inout) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: rebuild
|
||||
logical, intent(in), optional :: local
|
||||
end subroutine psb_dspins_v
|
||||
subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
|
||||
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
|
||||
& psb_d_base_vect_type, psb_d_vect_type, &
|
||||
|
||||
@@ -180,9 +180,9 @@ contains
|
||||
call mld%mold(x%v,info)
|
||||
#endif
|
||||
endif
|
||||
|
||||
!!$ write(0,*) 'Size invect',size(invect)
|
||||
if (info == psb_success_) call x%v%bld(invect)
|
||||
|
||||
|
||||
end subroutine d_vect_bld_x
|
||||
|
||||
|
||||
@@ -663,3 +663,636 @@ contains
|
||||
end subroutine d_vect_cnv
|
||||
|
||||
end module psb_d_vect_mod
|
||||
|
||||
|
||||
|
||||
|
||||
module psb_d_multivect_mod
|
||||
|
||||
use psb_d_base_multivect_mod
|
||||
use psb_const_mod
|
||||
|
||||
private
|
||||
|
||||
type psb_d_multivect_type
|
||||
class(psb_d_base_multivect_type), allocatable :: v
|
||||
contains
|
||||
procedure, pass(x) :: get_nrows => d_vect_get_nrows
|
||||
procedure, pass(x) :: get_ncols => d_vect_get_ncols
|
||||
procedure, pass(x) :: sizeof => d_vect_sizeof
|
||||
procedure, pass(x) :: get_fmt => d_vect_get_fmt
|
||||
!!$ procedure, pass(x) :: dot_v => d_vect_dot_v
|
||||
!!$ procedure, pass(x) :: dot_a => d_vect_dot_a
|
||||
!!$ generic, public :: dot => dot_v, dot_a
|
||||
!!$ procedure, pass(y) :: axpby_v => d_vect_axpby_v
|
||||
!!$ procedure, pass(y) :: axpby_a => d_vect_axpby_a
|
||||
!!$ generic, public :: axpby => axpby_v, axpby_a
|
||||
!!$ procedure, pass(y) :: mlt_v => d_vect_mlt_v
|
||||
!!$ procedure, pass(y) :: mlt_a => d_vect_mlt_a
|
||||
!!$ procedure, pass(z) :: mlt_a_2 => d_vect_mlt_a_2
|
||||
!!$ procedure, pass(z) :: mlt_v_2 => d_vect_mlt_v_2
|
||||
!!$ procedure, pass(z) :: mlt_va => d_vect_mlt_va
|
||||
!!$ procedure, pass(z) :: mlt_av => d_vect_mlt_av
|
||||
!!$ generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
|
||||
!!$ & mlt_v_2, mlt_av, mlt_va
|
||||
!!$ procedure, pass(x) :: scal => d_vect_scal
|
||||
!!$ procedure, pass(x) :: nrm2 => d_vect_nrm2
|
||||
!!$ procedure, pass(x) :: amax => d_vect_amax
|
||||
!!$ procedure, pass(x) :: asum => d_vect_asum
|
||||
procedure, pass(x) :: all => d_vect_all
|
||||
procedure, pass(x) :: reall => d_vect_reall
|
||||
procedure, pass(x) :: zero => d_vect_zero
|
||||
procedure, pass(x) :: asb => d_vect_asb
|
||||
procedure, pass(x) :: sync => d_vect_sync
|
||||
!!$ procedure, pass(x) :: gthab => d_vect_gthab
|
||||
!!$ procedure, pass(x) :: gthzv => d_vect_gthzv
|
||||
!!$ generic, public :: gth => gthab, gthzv
|
||||
!!$ procedure, pass(y) :: sctb => d_vect_sctb
|
||||
!!$ generic, public :: sct => sctb
|
||||
procedure, pass(x) :: free => d_vect_free
|
||||
procedure, pass(x) :: ins => d_vect_ins
|
||||
procedure, pass(x) :: bld_x => d_vect_bld_x
|
||||
procedure, pass(x) :: bld_n => d_vect_bld_n
|
||||
generic, public :: bld => bld_x, bld_n
|
||||
procedure, pass(x) :: get_vect => d_vect_get_vect
|
||||
procedure, pass(x) :: cnv => d_vect_cnv
|
||||
procedure, pass(x) :: set_scal => d_vect_set_scal
|
||||
procedure, pass(x) :: set_vect => d_vect_set_vect
|
||||
generic, public :: set => set_vect, set_scal
|
||||
procedure, pass(x) :: clone => d_vect_clone
|
||||
end type psb_d_multivect_type
|
||||
|
||||
public :: psb_d_multivect, psb_d_multivect_type,&
|
||||
& psb_set_multivect_default, psb_get_multivect_default
|
||||
|
||||
interface psb_d_multivect
|
||||
module procedure constructor, size_const
|
||||
end interface
|
||||
|
||||
class(psb_d_base_multivect_type), allocatable, target,&
|
||||
& save, private :: psb_d_base_multivect_default
|
||||
|
||||
interface psb_set_multivect_default
|
||||
module procedure psb_d_set_multivect_default
|
||||
end interface
|
||||
|
||||
interface psb_get_vect_default
|
||||
module procedure psb_d_get_multivect_default
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine psb_d_set_multivect_default(v)
|
||||
implicit none
|
||||
class(psb_d_base_multivect_type), intent(in) :: v
|
||||
|
||||
if (allocated(psb_d_base_multivect_default)) then
|
||||
deallocate(psb_d_base_multivect_default)
|
||||
end if
|
||||
allocate(psb_d_base_multivect_default, mold=v)
|
||||
|
||||
end subroutine psb_d_set_multivect_default
|
||||
|
||||
function psb_d_get_multivect_default(v) result(res)
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(in) :: v
|
||||
class(psb_d_base_multivect_type), pointer :: res
|
||||
|
||||
res => psb_d_get_base_multivect_default()
|
||||
|
||||
end function psb_d_get_multivect_default
|
||||
|
||||
|
||||
function psb_d_get_base_multivect_default() result(res)
|
||||
implicit none
|
||||
class(psb_d_base_multivect_type), pointer :: res
|
||||
|
||||
if (.not.allocated(psb_d_base_multivect_default)) then
|
||||
allocate(psb_d_base_multivect_type :: psb_d_base_multivect_default)
|
||||
end if
|
||||
|
||||
res => psb_d_base_multivect_default
|
||||
|
||||
end function psb_d_get_base_multivect_default
|
||||
|
||||
|
||||
subroutine d_vect_clone(x,y,info)
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
class(psb_d_multivect_type), intent(inout) :: y
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
call y%free(info)
|
||||
if ((info==0).and.allocated(x%v)) then
|
||||
call y%bld(x%get_vect(),mold=x%v)
|
||||
end if
|
||||
end subroutine d_vect_clone
|
||||
|
||||
subroutine d_vect_bld_x(x,invect,mold)
|
||||
real(psb_dpk_), intent(in) :: invect(:,:)
|
||||
class(psb_d_multivect_type), intent(out) :: x
|
||||
class(psb_d_base_multivect_type), intent(in), optional :: mold
|
||||
integer(psb_ipk_) :: info
|
||||
class(psb_d_base_multivect_type), pointer :: mld
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(x%v,info)
|
||||
#endif
|
||||
else
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default())
|
||||
#else
|
||||
mld = psb_d_get_base_multivect_default()
|
||||
call mld%mold(x%v,info)
|
||||
#endif
|
||||
endif
|
||||
|
||||
if (info == psb_success_) call x%v%bld(invect)
|
||||
|
||||
end subroutine d_vect_bld_x
|
||||
|
||||
|
||||
subroutine d_vect_bld_n(x,m,n,mold)
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
class(psb_d_multivect_type), intent(out) :: x
|
||||
class(psb_d_base_multivect_type), intent(in), optional :: mold
|
||||
integer(psb_ipk_) :: info
|
||||
class(psb_d_base_multivect_type), pointer :: mld
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(x%v,info)
|
||||
#endif
|
||||
else
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default())
|
||||
#else
|
||||
mld = psb_d_get_base_multivect_default()
|
||||
call mld%mold(x%v,info)
|
||||
#endif
|
||||
endif
|
||||
if (info == psb_success_) call x%v%bld(m,n)
|
||||
|
||||
end subroutine d_vect_bld_n
|
||||
|
||||
function d_vect_get_vect(x) result(res)
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
real(psb_dpk_), allocatable :: res(:,:)
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (allocated(x%v)) then
|
||||
res = x%v%get_vect()
|
||||
end if
|
||||
end function d_vect_get_vect
|
||||
|
||||
subroutine d_vect_set_scal(x,val)
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
|
||||
integer(psb_ipk_) :: info
|
||||
if (allocated(x%v)) call x%v%set(val)
|
||||
|
||||
end subroutine d_vect_set_scal
|
||||
|
||||
subroutine d_vect_set_vect(x,val)
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
real(psb_dpk_), intent(in) :: val(:,:)
|
||||
|
||||
integer(psb_ipk_) :: info
|
||||
if (allocated(x%v)) call x%v%set(val)
|
||||
|
||||
end subroutine d_vect_set_vect
|
||||
|
||||
|
||||
function constructor(x) result(this)
|
||||
real(psb_dpk_) :: x(:,:)
|
||||
type(psb_d_multivect_type) :: this
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
call this%bld(x)
|
||||
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
|
||||
|
||||
end function constructor
|
||||
|
||||
|
||||
function size_const(m,n) result(this)
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
type(psb_d_multivect_type) :: this
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
call this%bld(m,n)
|
||||
call this%asb(m,n,info)
|
||||
|
||||
end function size_const
|
||||
|
||||
function d_vect_get_nrows(x) result(res)
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(in) :: x
|
||||
real(psb_dpk_) :: res
|
||||
res = 0
|
||||
if (allocated(x%v)) res = x%v%get_nrows()
|
||||
end function d_vect_get_nrows
|
||||
|
||||
function d_vect_get_ncols(x) result(res)
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(in) :: x
|
||||
real(psb_dpk_) :: res
|
||||
res = 0
|
||||
if (allocated(x%v)) res = x%v%get_ncols()
|
||||
end function d_vect_get_ncols
|
||||
|
||||
function d_vect_sizeof(x) result(res)
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(in) :: x
|
||||
integer(psb_long_int_k_) :: res
|
||||
res = 0
|
||||
if (allocated(x%v)) res = x%v%sizeof()
|
||||
end function d_vect_sizeof
|
||||
|
||||
function d_vect_get_fmt(x) result(res)
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(in) :: x
|
||||
character(len=5) :: res
|
||||
res = 'NULL'
|
||||
if (allocated(x%v)) res = x%v%get_fmt()
|
||||
end function d_vect_get_fmt
|
||||
|
||||
!!$ function d_vect_dot_v(n,x,y) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x, y
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ real(psb_dpk_) :: res
|
||||
!!$
|
||||
!!$ res = izero
|
||||
!!$ if (allocated(x%v).and.allocated(y%v)) &
|
||||
!!$ & res = x%v%dot(n,y%v)
|
||||
!!$
|
||||
!!$ end function d_vect_dot_v
|
||||
!!$
|
||||
!!$ function d_vect_dot_a(n,x,y) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ real(psb_dpk_), intent(in) :: y(:)
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ real(psb_dpk_) :: res
|
||||
!!$
|
||||
!!$ res = izero
|
||||
!!$ if (allocated(x%v)) &
|
||||
!!$ & res = x%v%dot(n,y)
|
||||
!!$
|
||||
!!$ end function d_vect_dot_a
|
||||
!!$
|
||||
!!$ subroutine d_vect_axpby_v(m,alpha, x, beta, y, info)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: m
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: y
|
||||
!!$ real(psb_dpk_), intent (in) :: alpha, beta
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$
|
||||
!!$ if (allocated(x%v).and.allocated(y%v)) then
|
||||
!!$ call y%v%axpby(m,alpha,x%v,beta,info)
|
||||
!!$ else
|
||||
!!$ info = psb_err_invalid_vect_state_
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end subroutine d_vect_axpby_v
|
||||
!!$
|
||||
!!$ subroutine d_vect_axpby_a(m,alpha, x, beta, y, info)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: m
|
||||
!!$ real(psb_dpk_), intent(in) :: x(:)
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: y
|
||||
!!$ real(psb_dpk_), intent (in) :: alpha, beta
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$
|
||||
!!$ if (allocated(y%v)) &
|
||||
!!$ & call y%v%axpby(m,alpha,x,beta,info)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_axpby_a
|
||||
!!$
|
||||
!!$
|
||||
!!$ subroutine d_vect_mlt_v(x, y, info)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: y
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(x%v).and.allocated(y%v)) &
|
||||
!!$ & call y%v%mlt(x%v,info)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_mlt_v
|
||||
!!$
|
||||
!!$ subroutine d_vect_mlt_a(x, y, info)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ real(psb_dpk_), intent(in) :: x(:)
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: y
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(y%v)) &
|
||||
!!$ & call y%v%mlt(x,info)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_mlt_a
|
||||
!!$
|
||||
!!$
|
||||
!!$ subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ real(psb_dpk_), intent(in) :: alpha,beta
|
||||
!!$ real(psb_dpk_), intent(in) :: y(:)
|
||||
!!$ real(psb_dpk_), intent(in) :: x(:)
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: z
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(z%v)) &
|
||||
!!$ & call z%v%mlt(alpha,x,y,beta,info)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_mlt_a_2
|
||||
!!$
|
||||
!!$ subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ real(psb_dpk_), intent(in) :: alpha,beta
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: y
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: z
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ character(len=1), intent(in), optional :: conjgx, conjgy
|
||||
!!$
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(x%v).and.allocated(y%v).and.&
|
||||
!!$ & allocated(z%v)) &
|
||||
!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_mlt_v_2
|
||||
!!$
|
||||
!!$ subroutine d_vect_mlt_av(alpha,x,y,beta,z,info)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ real(psb_dpk_), intent(in) :: alpha,beta
|
||||
!!$ real(psb_dpk_), intent(in) :: x(:)
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: y
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: z
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(z%v).and.allocated(y%v)) &
|
||||
!!$ & call z%v%mlt(alpha,x,y%v,beta,info)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_mlt_av
|
||||
!!$
|
||||
!!$ subroutine d_vect_mlt_va(alpha,x,y,beta,z,info)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ real(psb_dpk_), intent(in) :: alpha,beta
|
||||
!!$ real(psb_dpk_), intent(in) :: y(:)
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: z
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$
|
||||
!!$ if (allocated(z%v).and.allocated(x%v)) &
|
||||
!!$ & call z%v%mlt(alpha,x%v,y,beta,info)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_mlt_va
|
||||
!!$
|
||||
!!$ subroutine d_vect_scal(alpha, x)
|
||||
!!$ use psd_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ real(psb_dpk_), intent (in) :: alpha
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) call x%v%scal(alpha)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_scal
|
||||
!!$
|
||||
!!$
|
||||
!!$ function d_vect_nrm2(n,x) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ real(psb_dpk_) :: res
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) then
|
||||
!!$ res = x%v%nrm2(n)
|
||||
!!$ else
|
||||
!!$ res = izero
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end function d_vect_nrm2
|
||||
!!$
|
||||
!!$ function d_vect_amax(n,x) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ real(psb_dpk_) :: res
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) then
|
||||
!!$ res = x%v%amax(n)
|
||||
!!$ else
|
||||
!!$ res = izero
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end function d_vect_amax
|
||||
!!$
|
||||
!!$ function d_vect_asum(n,x) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_d_multivect_type), intent(inout) :: x
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ real(psb_dpk_) :: res
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) then
|
||||
!!$ res = x%v%asum(n)
|
||||
!!$ else
|
||||
!!$ res = izero
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end function d_vect_asum
|
||||
|
||||
subroutine d_vect_all(m,n, x, info, mold)
|
||||
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
class(psb_d_multivect_type), intent(out) :: x
|
||||
class(psb_d_base_multivect_type), intent(in), optional :: mold
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(x%v,info)
|
||||
#endif
|
||||
else
|
||||
allocate(psb_d_base_multivect_type :: x%v,stat=info)
|
||||
endif
|
||||
if (info == 0) then
|
||||
call x%v%all(m,n,info)
|
||||
else
|
||||
info = psb_err_alloc_dealloc_
|
||||
end if
|
||||
|
||||
end subroutine d_vect_all
|
||||
|
||||
subroutine d_vect_reall(m,n, x, info)
|
||||
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (.not.allocated(x%v)) &
|
||||
& call x%all(m,n,info)
|
||||
if (info == 0) &
|
||||
& call x%asb(m,n,info)
|
||||
|
||||
end subroutine d_vect_reall
|
||||
|
||||
subroutine d_vect_zero(x)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
|
||||
if (allocated(x%v)) call x%v%zero()
|
||||
|
||||
end subroutine d_vect_zero
|
||||
|
||||
subroutine d_vect_asb(m,n, x, info)
|
||||
use psi_serial_mod
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (allocated(x%v)) &
|
||||
& call x%v%asb(m,n,info)
|
||||
|
||||
end subroutine d_vect_asb
|
||||
|
||||
subroutine d_vect_sync(x)
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
|
||||
if (allocated(x%v)) &
|
||||
& call x%v%sync()
|
||||
|
||||
end subroutine d_vect_sync
|
||||
|
||||
!!$ subroutine d_vect_gthab(n,idx,alpha,x,beta,y)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ integer(psb_ipk_) :: n, idx(:)
|
||||
!!$ real(psb_dpk_) :: alpha, beta, y(:)
|
||||
!!$ class(psb_d_multivect_type) :: x
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) &
|
||||
!!$ & call x%v%gth(n,idx,alpha,beta,y)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_gthab
|
||||
!!$
|
||||
!!$ subroutine d_vect_gthzv(n,idx,x,y)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ integer(psb_ipk_) :: n, idx(:)
|
||||
!!$ real(psb_dpk_) :: y(:)
|
||||
!!$ class(psb_d_multivect_type) :: x
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) &
|
||||
!!$ & call x%v%gth(n,idx,y)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_gthzv
|
||||
!!$
|
||||
!!$ subroutine d_vect_sctb(n,idx,x,beta,y)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ integer(psb_ipk_) :: n, idx(:)
|
||||
!!$ real(psb_dpk_) :: beta, x(:)
|
||||
!!$ class(psb_d_multivect_type) :: y
|
||||
!!$
|
||||
!!$ if (allocated(y%v)) &
|
||||
!!$ & call y%v%sct(n,idx,x,beta)
|
||||
!!$
|
||||
!!$ end subroutine d_vect_sctb
|
||||
|
||||
subroutine d_vect_free(x, info)
|
||||
use psi_serial_mod
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (allocated(x%v)) then
|
||||
call x%v%free(info)
|
||||
if (info == 0) deallocate(x%v,stat=info)
|
||||
end if
|
||||
|
||||
end subroutine d_vect_free
|
||||
|
||||
subroutine d_vect_ins(n,irl,val,dupl,x,info)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(in) :: n, dupl
|
||||
integer(psb_ipk_), intent(in) :: irl(:)
|
||||
real(psb_dpk_), intent(in) :: val(:,:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = 0
|
||||
if (.not.allocated(x%v)) then
|
||||
info = psb_err_invalid_vect_state_
|
||||
return
|
||||
end if
|
||||
|
||||
call x%v%ins(n,irl,val,dupl,info)
|
||||
|
||||
end subroutine d_vect_ins
|
||||
|
||||
|
||||
subroutine d_vect_cnv(x,mold)
|
||||
class(psb_d_multivect_type), intent(inout) :: x
|
||||
class(psb_d_base_multivect_type), intent(in), optional :: mold
|
||||
class(psb_d_base_multivect_type), allocatable :: tmp
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(tmp,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(tmp,info)
|
||||
#endif
|
||||
if (allocated(x%v)) then
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
end if
|
||||
call move_alloc(tmp,x%v)
|
||||
end if
|
||||
end subroutine d_vect_cnv
|
||||
|
||||
end module psb_d_multivect_mod
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -653,3 +653,635 @@ contains
|
||||
end subroutine i_vect_cnv
|
||||
|
||||
end module psb_i_vect_mod
|
||||
|
||||
|
||||
|
||||
module psb_i_multivect_mod
|
||||
|
||||
use psb_i_base_multivect_mod
|
||||
use psb_const_mod
|
||||
|
||||
private
|
||||
|
||||
type psb_i_multivect_type
|
||||
class(psb_i_base_multivect_type), allocatable :: v
|
||||
contains
|
||||
procedure, pass(x) :: get_nrows => i_vect_get_nrows
|
||||
procedure, pass(x) :: get_ncols => i_vect_get_ncols
|
||||
procedure, pass(x) :: sizeof => i_vect_sizeof
|
||||
procedure, pass(x) :: get_fmt => i_vect_get_fmt
|
||||
!!$ procedure, pass(x) :: dot_v => i_vect_dot_v
|
||||
!!$ procedure, pass(x) :: dot_a => i_vect_dot_a
|
||||
!!$ generic, public :: dot => dot_v, dot_a
|
||||
!!$ procedure, pass(y) :: axpby_v => i_vect_axpby_v
|
||||
!!$ procedure, pass(y) :: axpby_a => i_vect_axpby_a
|
||||
!!$ generic, public :: axpby => axpby_v, axpby_a
|
||||
!!$ procedure, pass(y) :: mlt_v => i_vect_mlt_v
|
||||
!!$ procedure, pass(y) :: mlt_a => i_vect_mlt_a
|
||||
!!$ procedure, pass(z) :: mlt_a_2 => i_vect_mlt_a_2
|
||||
!!$ procedure, pass(z) :: mlt_v_2 => i_vect_mlt_v_2
|
||||
!!$ procedure, pass(z) :: mlt_va => i_vect_mlt_va
|
||||
!!$ procedure, pass(z) :: mlt_av => i_vect_mlt_av
|
||||
!!$ generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
|
||||
!!$ & mlt_v_2, mlt_av, mlt_va
|
||||
!!$ procedure, pass(x) :: scal => i_vect_scal
|
||||
!!$ procedure, pass(x) :: nrm2 => i_vect_nrm2
|
||||
!!$ procedure, pass(x) :: amax => i_vect_amax
|
||||
!!$ procedure, pass(x) :: asum => i_vect_asum
|
||||
procedure, pass(x) :: all => i_vect_all
|
||||
procedure, pass(x) :: reall => i_vect_reall
|
||||
procedure, pass(x) :: zero => i_vect_zero
|
||||
procedure, pass(x) :: asb => i_vect_asb
|
||||
procedure, pass(x) :: sync => i_vect_sync
|
||||
!!$ procedure, pass(x) :: gthab => i_vect_gthab
|
||||
!!$ procedure, pass(x) :: gthzv => i_vect_gthzv
|
||||
!!$ generic, public :: gth => gthab, gthzv
|
||||
!!$ procedure, pass(y) :: sctb => i_vect_sctb
|
||||
!!$ generic, public :: sct => sctb
|
||||
procedure, pass(x) :: free => i_vect_free
|
||||
procedure, pass(x) :: ins => i_vect_ins
|
||||
procedure, pass(x) :: bld_x => i_vect_bld_x
|
||||
procedure, pass(x) :: bld_n => i_vect_bld_n
|
||||
generic, public :: bld => bld_x, bld_n
|
||||
procedure, pass(x) :: get_vect => i_vect_get_vect
|
||||
procedure, pass(x) :: cnv => i_vect_cnv
|
||||
procedure, pass(x) :: set_scal => i_vect_set_scal
|
||||
procedure, pass(x) :: set_vect => i_vect_set_vect
|
||||
generic, public :: set => set_vect, set_scal
|
||||
procedure, pass(x) :: clone => i_vect_clone
|
||||
end type psb_i_multivect_type
|
||||
|
||||
public :: psb_i_multivect, psb_i_multivect_type,&
|
||||
& psb_set_multivect_default, psb_get_multivect_default
|
||||
|
||||
interface psb_i_multivect
|
||||
module procedure constructor, size_const
|
||||
end interface
|
||||
|
||||
class(psb_i_base_multivect_type), allocatable, target,&
|
||||
& save, private :: psb_i_base_multivect_default
|
||||
|
||||
interface psb_set_multivect_default
|
||||
module procedure psb_i_set_multivect_default
|
||||
end interface
|
||||
|
||||
interface psb_get_vect_default
|
||||
module procedure psb_i_get_multivect_default
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine psb_i_set_multivect_default(v)
|
||||
implicit none
|
||||
class(psb_i_base_multivect_type), intent(in) :: v
|
||||
|
||||
if (allocated(psb_i_base_multivect_default)) then
|
||||
deallocate(psb_i_base_multivect_default)
|
||||
end if
|
||||
allocate(psb_i_base_multivect_default, mold=v)
|
||||
|
||||
end subroutine psb_i_set_multivect_default
|
||||
|
||||
function psb_i_get_multivect_default(v) result(res)
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(in) :: v
|
||||
class(psb_i_base_multivect_type), pointer :: res
|
||||
|
||||
res => psb_i_get_base_multivect_default()
|
||||
|
||||
end function psb_i_get_multivect_default
|
||||
|
||||
|
||||
function psb_i_get_base_multivect_default() result(res)
|
||||
implicit none
|
||||
class(psb_i_base_multivect_type), pointer :: res
|
||||
|
||||
if (.not.allocated(psb_i_base_multivect_default)) then
|
||||
allocate(psb_i_base_multivect_type :: psb_i_base_multivect_default)
|
||||
end if
|
||||
|
||||
res => psb_i_base_multivect_default
|
||||
|
||||
end function psb_i_get_base_multivect_default
|
||||
|
||||
|
||||
subroutine i_vect_clone(x,y,info)
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
class(psb_i_multivect_type), intent(inout) :: y
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
call y%free(info)
|
||||
if ((info==0).and.allocated(x%v)) then
|
||||
call y%bld(x%get_vect(),mold=x%v)
|
||||
end if
|
||||
end subroutine i_vect_clone
|
||||
|
||||
subroutine i_vect_bld_x(x,invect,mold)
|
||||
integer(psb_ipk_), intent(in) :: invect(:,:)
|
||||
class(psb_i_multivect_type), intent(out) :: x
|
||||
class(psb_i_base_multivect_type), intent(in), optional :: mold
|
||||
integer(psb_ipk_) :: info
|
||||
class(psb_i_base_multivect_type), pointer :: mld
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(x%v,info)
|
||||
#endif
|
||||
else
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default())
|
||||
#else
|
||||
mld = psb_i_get_base_multivect_default()
|
||||
call mld%mold(x%v,info)
|
||||
#endif
|
||||
endif
|
||||
|
||||
if (info == psb_success_) call x%v%bld(invect)
|
||||
|
||||
end subroutine i_vect_bld_x
|
||||
|
||||
|
||||
subroutine i_vect_bld_n(x,m,n,mold)
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
class(psb_i_multivect_type), intent(out) :: x
|
||||
class(psb_i_base_multivect_type), intent(in), optional :: mold
|
||||
integer(psb_ipk_) :: info
|
||||
class(psb_i_base_multivect_type), pointer :: mld
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(x%v,info)
|
||||
#endif
|
||||
else
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default())
|
||||
#else
|
||||
mld = psb_i_get_base_multivect_default()
|
||||
call mld%mold(x%v,info)
|
||||
#endif
|
||||
endif
|
||||
if (info == psb_success_) call x%v%bld(m,n)
|
||||
|
||||
end subroutine i_vect_bld_n
|
||||
|
||||
function i_vect_get_vect(x) result(res)
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), allocatable :: res(:,:)
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (allocated(x%v)) then
|
||||
res = x%v%get_vect()
|
||||
end if
|
||||
end function i_vect_get_vect
|
||||
|
||||
subroutine i_vect_set_scal(x,val)
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
|
||||
integer(psb_ipk_) :: info
|
||||
if (allocated(x%v)) call x%v%set(val)
|
||||
|
||||
end subroutine i_vect_set_scal
|
||||
|
||||
subroutine i_vect_set_vect(x,val)
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(in) :: val(:,:)
|
||||
|
||||
integer(psb_ipk_) :: info
|
||||
if (allocated(x%v)) call x%v%set(val)
|
||||
|
||||
end subroutine i_vect_set_vect
|
||||
|
||||
|
||||
function constructor(x) result(this)
|
||||
integer(psb_ipk_) :: x(:,:)
|
||||
type(psb_i_multivect_type) :: this
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
call this%bld(x)
|
||||
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
|
||||
|
||||
end function constructor
|
||||
|
||||
|
||||
function size_const(m,n) result(this)
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
type(psb_i_multivect_type) :: this
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
call this%bld(m,n)
|
||||
call this%asb(m,n,info)
|
||||
|
||||
end function size_const
|
||||
|
||||
function i_vect_get_nrows(x) result(res)
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(in) :: x
|
||||
integer(psb_ipk_) :: res
|
||||
res = 0
|
||||
if (allocated(x%v)) res = x%v%get_nrows()
|
||||
end function i_vect_get_nrows
|
||||
|
||||
function i_vect_get_ncols(x) result(res)
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(in) :: x
|
||||
integer(psb_ipk_) :: res
|
||||
res = 0
|
||||
if (allocated(x%v)) res = x%v%get_ncols()
|
||||
end function i_vect_get_ncols
|
||||
|
||||
function i_vect_sizeof(x) result(res)
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(in) :: x
|
||||
integer(psb_long_int_k_) :: res
|
||||
res = 0
|
||||
if (allocated(x%v)) res = x%v%sizeof()
|
||||
end function i_vect_sizeof
|
||||
|
||||
function i_vect_get_fmt(x) result(res)
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(in) :: x
|
||||
character(len=5) :: res
|
||||
res = 'NULL'
|
||||
if (allocated(x%v)) res = x%v%get_fmt()
|
||||
end function i_vect_get_fmt
|
||||
|
||||
!!$ function i_vect_dot_v(n,x,y) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x, y
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ integer(psb_ipk_) :: res
|
||||
!!$
|
||||
!!$ res = izero
|
||||
!!$ if (allocated(x%v).and.allocated(y%v)) &
|
||||
!!$ & res = x%v%dot(n,y%v)
|
||||
!!$
|
||||
!!$ end function i_vect_dot_v
|
||||
!!$
|
||||
!!$ function i_vect_dot_a(n,x,y) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ integer(psb_ipk_), intent(in) :: y(:)
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ integer(psb_ipk_) :: res
|
||||
!!$
|
||||
!!$ res = izero
|
||||
!!$ if (allocated(x%v)) &
|
||||
!!$ & res = x%v%dot(n,y)
|
||||
!!$
|
||||
!!$ end function i_vect_dot_a
|
||||
!!$
|
||||
!!$ subroutine i_vect_axpby_v(m,alpha, x, beta, y, info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: m
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: y
|
||||
!!$ integer(psb_ipk_), intent (in) :: alpha, beta
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$
|
||||
!!$ if (allocated(x%v).and.allocated(y%v)) then
|
||||
!!$ call y%v%axpby(m,alpha,x%v,beta,info)
|
||||
!!$ else
|
||||
!!$ info = psb_err_invalid_vect_state_
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end subroutine i_vect_axpby_v
|
||||
!!$
|
||||
!!$ subroutine i_vect_axpby_a(m,alpha, x, beta, y, info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: m
|
||||
!!$ integer(psb_ipk_), intent(in) :: x(:)
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: y
|
||||
!!$ integer(psb_ipk_), intent (in) :: alpha, beta
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$
|
||||
!!$ if (allocated(y%v)) &
|
||||
!!$ & call y%v%axpby(m,alpha,x,beta,info)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_axpby_a
|
||||
!!$
|
||||
!!$
|
||||
!!$ subroutine i_vect_mlt_v(x, y, info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: y
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(x%v).and.allocated(y%v)) &
|
||||
!!$ & call y%v%mlt(x%v,info)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_mlt_v
|
||||
!!$
|
||||
!!$ subroutine i_vect_mlt_a(x, y, info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: x(:)
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: y
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(y%v)) &
|
||||
!!$ & call y%v%mlt(x,info)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_mlt_a
|
||||
!!$
|
||||
!!$
|
||||
!!$ subroutine i_vect_mlt_a_2(alpha,x,y,beta,z,info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: alpha,beta
|
||||
!!$ integer(psb_ipk_), intent(in) :: y(:)
|
||||
!!$ integer(psb_ipk_), intent(in) :: x(:)
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: z
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(z%v)) &
|
||||
!!$ & call z%v%mlt(alpha,x,y,beta,info)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_mlt_a_2
|
||||
!!$
|
||||
!!$ subroutine i_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: alpha,beta
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: y
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: z
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ character(len=1), intent(in), optional :: conjgx, conjgy
|
||||
!!$
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(x%v).and.allocated(y%v).and.&
|
||||
!!$ & allocated(z%v)) &
|
||||
!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_mlt_v_2
|
||||
!!$
|
||||
!!$ subroutine i_vect_mlt_av(alpha,x,y,beta,z,info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: alpha,beta
|
||||
!!$ integer(psb_ipk_), intent(in) :: x(:)
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: y
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: z
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$ if (allocated(z%v).and.allocated(y%v)) &
|
||||
!!$ & call z%v%mlt(alpha,x,y%v,beta,info)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_mlt_av
|
||||
!!$
|
||||
!!$ subroutine i_vect_mlt_va(alpha,x,y,beta,z,info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_ipk_), intent(in) :: alpha,beta
|
||||
!!$ integer(psb_ipk_), intent(in) :: y(:)
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: z
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_) :: i, n
|
||||
!!$
|
||||
!!$ info = 0
|
||||
!!$
|
||||
!!$ if (allocated(z%v).and.allocated(x%v)) &
|
||||
!!$ & call z%v%mlt(alpha,x%v,y,beta,info)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_mlt_va
|
||||
!!$
|
||||
!!$ subroutine i_vect_scal(alpha, x)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ integer(psb_ipk_), intent (in) :: alpha
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) call x%v%scal(alpha)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_scal
|
||||
!!$
|
||||
!!$
|
||||
!!$ function i_vect_nrm2(n,x) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ integer(psb_ipk_) :: res
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) then
|
||||
!!$ res = x%v%nrm2(n)
|
||||
!!$ else
|
||||
!!$ res = izero
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end function i_vect_nrm2
|
||||
!!$
|
||||
!!$ function i_vect_amax(n,x) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ integer(psb_ipk_) :: res
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) then
|
||||
!!$ res = x%v%amax(n)
|
||||
!!$ else
|
||||
!!$ res = izero
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end function i_vect_amax
|
||||
!!$
|
||||
!!$ function i_vect_asum(n,x) result(res)
|
||||
!!$ implicit none
|
||||
!!$ class(psb_i_multivect_type), intent(inout) :: x
|
||||
!!$ integer(psb_ipk_), intent(in) :: n
|
||||
!!$ integer(psb_ipk_) :: res
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) then
|
||||
!!$ res = x%v%asum(n)
|
||||
!!$ else
|
||||
!!$ res = izero
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end function i_vect_asum
|
||||
|
||||
subroutine i_vect_all(m,n, x, info, mold)
|
||||
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
class(psb_i_multivect_type), intent(out) :: x
|
||||
class(psb_i_base_multivect_type), intent(in), optional :: mold
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(x%v,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(x%v,info)
|
||||
#endif
|
||||
else
|
||||
allocate(psb_i_base_multivect_type :: x%v,stat=info)
|
||||
endif
|
||||
if (info == 0) then
|
||||
call x%v%all(m,n,info)
|
||||
else
|
||||
info = psb_err_alloc_dealloc_
|
||||
end if
|
||||
|
||||
end subroutine i_vect_all
|
||||
|
||||
subroutine i_vect_reall(m,n, x, info)
|
||||
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (.not.allocated(x%v)) &
|
||||
& call x%all(m,n,info)
|
||||
if (info == 0) &
|
||||
& call x%asb(m,n,info)
|
||||
|
||||
end subroutine i_vect_reall
|
||||
|
||||
subroutine i_vect_zero(x)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
|
||||
if (allocated(x%v)) call x%v%zero()
|
||||
|
||||
end subroutine i_vect_zero
|
||||
|
||||
subroutine i_vect_asb(m,n, x, info)
|
||||
use psi_serial_mod
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: m,n
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (allocated(x%v)) &
|
||||
& call x%v%asb(m,n,info)
|
||||
|
||||
end subroutine i_vect_asb
|
||||
|
||||
subroutine i_vect_sync(x)
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
|
||||
if (allocated(x%v)) &
|
||||
& call x%v%sync()
|
||||
|
||||
end subroutine i_vect_sync
|
||||
|
||||
!!$ subroutine i_vect_gthab(n,idx,alpha,x,beta,y)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ integer(psb_ipk_) :: n, idx(:)
|
||||
!!$ integer(psb_ipk_) :: alpha, beta, y(:)
|
||||
!!$ class(psb_i_multivect_type) :: x
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) &
|
||||
!!$ & call x%v%gth(n,idx,alpha,beta,y)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_gthab
|
||||
!!$
|
||||
!!$ subroutine i_vect_gthzv(n,idx,x,y)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ integer(psb_ipk_) :: n, idx(:)
|
||||
!!$ integer(psb_ipk_) :: y(:)
|
||||
!!$ class(psb_i_multivect_type) :: x
|
||||
!!$
|
||||
!!$ if (allocated(x%v)) &
|
||||
!!$ & call x%v%gth(n,idx,y)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_gthzv
|
||||
!!$
|
||||
!!$ subroutine i_vect_sctb(n,idx,x,beta,y)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ integer(psb_ipk_) :: n, idx(:)
|
||||
!!$ integer(psb_ipk_) :: beta, x(:)
|
||||
!!$ class(psb_i_multivect_type) :: y
|
||||
!!$
|
||||
!!$ if (allocated(y%v)) &
|
||||
!!$ & call y%v%sct(n,idx,x,beta)
|
||||
!!$
|
||||
!!$ end subroutine i_vect_sctb
|
||||
|
||||
subroutine i_vect_free(x, info)
|
||||
use psi_serial_mod
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (allocated(x%v)) then
|
||||
call x%v%free(info)
|
||||
if (info == 0) deallocate(x%v,stat=info)
|
||||
end if
|
||||
|
||||
end subroutine i_vect_free
|
||||
|
||||
subroutine i_vect_ins(n,irl,val,dupl,x,info)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
integer(psb_ipk_), intent(in) :: n, dupl
|
||||
integer(psb_ipk_), intent(in) :: irl(:)
|
||||
integer(psb_ipk_), intent(in) :: val(:,:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = 0
|
||||
if (.not.allocated(x%v)) then
|
||||
info = psb_err_invalid_vect_state_
|
||||
return
|
||||
end if
|
||||
|
||||
call x%v%ins(n,irl,val,dupl,info)
|
||||
|
||||
end subroutine i_vect_ins
|
||||
|
||||
|
||||
subroutine i_vect_cnv(x,mold)
|
||||
class(psb_i_multivect_type), intent(inout) :: x
|
||||
class(psb_i_base_multivect_type), intent(in), optional :: mold
|
||||
class(psb_i_base_multivect_type), allocatable :: tmp
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
if (present(mold)) then
|
||||
#ifdef HAVE_MOLD
|
||||
allocate(tmp,stat=info,mold=mold)
|
||||
#else
|
||||
call mold%mold(tmp,info)
|
||||
#endif
|
||||
if (allocated(x%v)) then
|
||||
call x%v%sync()
|
||||
if (info == psb_success_) call tmp%bld(x%v%v)
|
||||
call x%v%free(info)
|
||||
end if
|
||||
call move_alloc(tmp,x%v)
|
||||
end if
|
||||
end subroutine i_vect_cnv
|
||||
|
||||
end module psb_i_multivect_mod
|
||||
|
||||
@@ -4,4 +4,6 @@ module psb_vect_mod
|
||||
use psb_d_vect_mod
|
||||
use psb_c_vect_mod
|
||||
use psb_z_vect_mod
|
||||
use psb_i_multivect_mod
|
||||
use psb_d_multivect_mod
|
||||
end module psb_vect_mod
|
||||
|
||||
@@ -380,6 +380,9 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
|
||||
if (val%is_dev()) call val%sync()
|
||||
if (ia%is_dev()) call ia%sync()
|
||||
if (ja%is_dev()) call ja%sync()
|
||||
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
|
||||
else
|
||||
info = psb_err_invalid_mat_state_
|
||||
|
||||
@@ -733,8 +733,8 @@ end subroutine psb_d_trim
|
||||
|
||||
|
||||
|
||||
subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
use psb_d_mat_mod, psb_protect_name => psb_d_csput
|
||||
subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
use psb_d_mat_mod, psb_protect_name => psb_d_csput_a
|
||||
use psb_d_base_mat_mod
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
@@ -745,7 +745,7 @@ subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
integer(psb_ipk_), intent(in), optional :: gtl(:)
|
||||
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='csput'
|
||||
character(len=20) :: name='csput_a'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
info = psb_success_
|
||||
@@ -771,7 +771,54 @@ subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
return
|
||||
end if
|
||||
|
||||
end subroutine psb_d_csput
|
||||
end subroutine psb_d_csput_a
|
||||
|
||||
subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
|
||||
use psb_d_mat_mod, psb_protect_name => psb_d_csput_v
|
||||
use psb_d_base_mat_mod
|
||||
use psb_d_vect_mod, only : psb_d_vect_type
|
||||
use psb_i_vect_mod, only : psb_i_vect_type
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
class(psb_dspmat_type), intent(inout) :: a
|
||||
type(psb_d_vect_type), intent(inout) :: val
|
||||
type(psb_i_vect_type), intent(inout) :: ia, ja
|
||||
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: gtl(:)
|
||||
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='csput_a'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
if (.not.(a%is_bld().or.a%is_upd())) then
|
||||
info = psb_err_invalid_mat_state_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
|
||||
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
|
||||
else
|
||||
info = psb_err_invalid_mat_state_
|
||||
endif
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
|
||||
end subroutine psb_d_csput_v
|
||||
|
||||
|
||||
subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,&
|
||||
|
||||
@@ -332,3 +332,169 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
|
||||
|
||||
end subroutine psb_dspins_2desc
|
||||
|
||||
subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
|
||||
use psb_base_mod, psb_protect_name => psb_dspins_v
|
||||
use psi_mod
|
||||
implicit none
|
||||
|
||||
!....parameters...
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
type(psb_dspmat_type), intent(inout) :: a
|
||||
integer(psb_ipk_), intent(in) :: nz
|
||||
type(psb_i_vect_type), intent(inout) :: ia,ja
|
||||
type(psb_d_vect_type), intent(inout) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: rebuild, local
|
||||
!locals.....
|
||||
|
||||
integer(psb_ipk_) :: nrow, err_act, ncol, spstate
|
||||
integer(psb_ipk_) :: ictxt,np,me
|
||||
logical, parameter :: debug=.false.
|
||||
integer(psb_ipk_), parameter :: relocsz=200
|
||||
logical :: rebuild_, local_
|
||||
integer(psb_ipk_), allocatable :: ila(:),jla(:)
|
||||
real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_dspins'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
if (nz < 0) then
|
||||
info = 1111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
if (ia%get_nrows() < nz) then
|
||||
info = 1111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (ja%get_nrows() < nz) then
|
||||
info = 1111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
if (val%get_nrows() < nz) then
|
||||
info = 1111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
if (nz == 0) return
|
||||
|
||||
if (present(rebuild)) then
|
||||
rebuild_ = rebuild
|
||||
else
|
||||
rebuild_ = .false.
|
||||
endif
|
||||
|
||||
if (present(local)) then
|
||||
local_ = local
|
||||
else
|
||||
local_ = .false.
|
||||
endif
|
||||
|
||||
if (desc_a%is_bld()) then
|
||||
|
||||
!!$ if (local_) then
|
||||
info = psb_err_invalid_a_and_cd_state_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
!!$ else
|
||||
!!$ allocate(ila(nz),jla(nz),stat=info)
|
||||
!!$ if (info /= psb_success_) then
|
||||
!!$ ierr(1) = info
|
||||
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
|
||||
!!$ & a_err='allocate',i_err=ierr)
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
|
||||
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
|
||||
!!$
|
||||
!!$ if (info /= psb_success_) then
|
||||
!!$ ierr(1) = info
|
||||
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
|
||||
!!$ & a_err='psb_cdins',i_err=ierr)
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$ nrow = desc_a%get_local_rows()
|
||||
!!$ ncol = desc_a%get_local_cols()
|
||||
!!$
|
||||
!!$ if (a%is_bld()) then
|
||||
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
|
||||
!!$ if (info /= psb_success_) then
|
||||
!!$ info=psb_err_from_subroutine_
|
||||
!!$ call psb_errpush(info,name,a_err='a%csput')
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$ else
|
||||
!!$ info = psb_err_invalid_a_and_cd_state_
|
||||
!!$ call psb_errpush(info,name)
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$ endif
|
||||
|
||||
else if (desc_a%is_asb()) then
|
||||
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
if (local_) then
|
||||
t1=psb_wtime()
|
||||
call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info)
|
||||
tcsput=psb_wtime() - t1
|
||||
tcnv=0.0
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='a%csput')
|
||||
goto 9999
|
||||
end if
|
||||
else
|
||||
info = psb_err_invalid_cd_state_
|
||||
|
||||
!!$ t1=psb_wtime()
|
||||
!!$ allocate(ila(nz),jla(nz),stat=info)
|
||||
!!$ if (info /= psb_success_) then
|
||||
!!$ ierr(1) = info
|
||||
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
|
||||
!!$ & a_err='allocate',i_err=ierr)
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
|
||||
!!$ call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
|
||||
!!$ t2 = psb_Wtime()
|
||||
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
|
||||
!!$ t3=psb_wtime()
|
||||
!!$ tcnv=t2-t1
|
||||
!!$ tcsput=t3-t2
|
||||
!!$ if (info /= psb_success_) then
|
||||
!!$ info=psb_err_from_subroutine_
|
||||
!!$ call psb_errpush(info,name,a_err='a%csput')
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
end if
|
||||
!!$ write(0,*)'SPINS times: ',tcnv,tcsput
|
||||
else
|
||||
info = psb_err_invalid_cd_state_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error(ictxt)
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine psb_dspins_v
|
||||
|
||||
Reference in New Issue
Block a user