You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
psblas3/base/serial/impl/psb_base_mat_impl.f90

335 lines
9.5 KiB
Fortran

function psb_base_get_nz_row(idx,a) result(res)
use psb_error_mod
use psb_base_mat_mod, psb_protect_name => psb_base_get_nz_row
implicit none
integer(psb_ipk_), intent(in) :: idx
class(psb_base_sparse_mat), intent(in) :: a
integer(psb_ipk_) :: res
integer(psb_ipk_) :: err_act
character(len=20) :: name='base_get_nz_row'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function psb_base_get_nz_row
function psb_base_get_nzeros(a) result(res)
use psb_base_mat_mod, psb_protect_name => psb_base_get_nzeros
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer(psb_ipk_) :: res
integer(psb_ipk_) :: err_act
character(len=20) :: name='base_get_nzeros'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function psb_base_get_nzeros
function psb_base_get_size(a) result(res)
use psb_base_mat_mod, psb_protect_name => psb_base_get_size
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer(psb_ipk_) :: res
integer(psb_ipk_) :: err_act
character(len=20) :: name='get_size'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function psb_base_get_size
subroutine psb_base_reinit(a,clear)
use psb_base_mat_mod, psb_protect_name => psb_base_reinit
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
character(len=20) :: name='reinit'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
info = psb_err_missing_override_method_
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_reinit
subroutine psb_base_sparse_print(iout,a,iv,head,ivr,ivc)
use psb_base_mat_mod, psb_protect_name => psb_base_sparse_print
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: iout
class(psb_base_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act, info
character(len=20) :: name='sparse_print'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
info = psb_err_missing_override_method_
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_sparse_print
subroutine psb_base_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
use psb_base_mat_mod, psb_protect_name => psb_base_csgetptn
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
info = psb_err_missing_override_method_
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_csgetptn
subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev)
use psb_base_mat_mod, psb_protect_name => psb_base_get_neigh
use psb_error_mod
use psb_realloc_mod
use psb_sort_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in) :: idx
integer(psb_ipk_), intent(out) :: n
integer(psb_ipk_), allocatable, intent(out) :: neigh(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: lev
integer(psb_ipk_) :: lev_, i, nl, ifl,ill,&
& n1, err_act, nn, nidx,ntl,ma
integer(psb_ipk_), allocatable :: ia(:), ja(:)
character(len=20) :: name='get_neigh'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if(present(lev)) then
lev_ = lev
else
lev_=1
end if
! Turns out we can write get_neigh at this
! level
n = 0
ma = a%get_nrows()
call a%csget(idx,idx,n,ia,ja,info)
if (info == psb_success_) call psb_realloc(n,neigh,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
neigh(1:n) = ja(1:n)
ifl = 1
ill = n
do nl = 2, lev_
n1 = ill - ifl + 1
call psb_ensure_size(ill+n1*n1,neigh,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
ntl = 0
do i=ifl,ill
nidx=neigh(i)
if ((nidx /= idx).and.(nidx > 0).and.(nidx <= ma)) then
call a%csget(nidx,nidx,nn,ia,ja,info)
if (info == psb_success_) call psb_ensure_size(ill+ntl+nn,neigh,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn)
ntl = ntl+nn
end if
end do
call psb_msort_unique(neigh(ill+1:ill+ntl),nn,dir=psb_sort_up_)
ifl = ill + 1
ill = ill + nn
end do
call psb_msort_unique(neigh(1:ill),nn,dir=psb_sort_up_)
n = nn
call psb_erractionrestore(err_act)
return
9999 continue
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_get_neigh
subroutine psb_base_allocate_mnnz(m,n,a,nz)
use psb_base_mat_mod, psb_protect_name => psb_base_allocate_mnnz
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_base_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_allocate_mnnz
subroutine psb_base_reallocate_nz(nz,a)
use psb_base_mat_mod, psb_protect_name => psb_base_reallocate_nz
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: nz
class(psb_base_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_reallocate_nz
subroutine psb_base_free(a)
use psb_base_mat_mod, psb_protect_name => psb_base_free
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act
character(len=20) :: name='free'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_free
subroutine psb_base_trim(a)
use psb_base_mat_mod, psb_protect_name => psb_base_trim
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
!
! This is the base version.
! The correct action is: do nothing.
! Indeed, the more complicated the data structure, the
! more likely this is the only possible course.
!
return
end subroutine psb_base_trim