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/newserial/psbn_mat_impl.f03

246 lines
5.5 KiB
Fortran

subroutine psbn_d_csall(nr,nc,a,info,nz)
use psbn_d_base_mat_mod
use psb_realloc_mod
use psb_sort_mod
use psbn_d_mat_mod, psb_protect_name => psbn_d_csall
implicit none
type(psbn_d_sparse_mat), intent(out) :: a
integer, intent(in) :: nr,nc
integer, intent(out) :: info
integer, intent(in), optional :: nz
info = 0
call a%allocate(nr,nc,nz)
call a%set_bld()
return
end subroutine psbn_d_csall
subroutine psbn_d_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psbn_d_base_mat_mod
use psb_error_mod
use psbn_d_mat_mod, psb_protect_name => psbn_d_csput
implicit none
type(psbn_d_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
Integer :: err_act
character(len=20) :: name='psbn_csput'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.a%is_bld()) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
call a%a%csput(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl)
if (info /= 0) 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 psbn_d_csput
subroutine psbn_d_spcnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod
use psb_string_mod
use psbn_d_mat_mod, psb_protect_name => psbn_d_spcnv
implicit none
type(psbn_d_sparse_mat), intent(in) :: a
type(psbn_d_sparse_mat), intent(out) :: b
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: type
class(psbn_d_base_sparse_mat), intent(in), optional :: mold
class(psbn_d_base_sparse_mat), allocatable :: altmp
Integer :: err_act
character(len=20) :: name='psbn_cscnv'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (a%is_null()) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
call b%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call b%set_dupl(psbn_dupl_def_)
end if
if (count( (/present(mold),present(type) /)) > 1) then
info = 583
call psb_errpush(info,name,a_err='TYPE, MOLD')
goto 9999
end if
if (present(mold)) then
allocate(altmp, source=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psbn_d_coo_sparse_mat :: altmp, stat=info)
case default
info = 136
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
end if
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
call altmp%cp_from_fmt(a%a, info)
if (info /= 0) then
info = 4010
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b%a)
call b%set_asb()
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 psbn_d_spcnv
subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl)
use psb_error_mod
use psb_string_mod
use psbn_d_mat_mod, psb_protect_name => psbn_d_spcnv_ip
implicit none
type(psbn_d_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psbn_d_base_sparse_mat), intent(in), optional :: mold
class(psbn_d_base_sparse_mat), allocatable :: altmp
Integer :: err_act
character(len=20) :: name='psbn_cscnv'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (a%is_null()) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
call a%set_dupl(dupl)
else if (a%is_bld()) then
call a%set_dupl(psbn_dupl_def_)
end if
if (count( (/present(mold),present(type) /)) > 1) then
info = 583
call psb_errpush(info,name,a_err='TYPE, MOLD')
goto 9999
end if
if (present(mold)) then
allocate(altmp, source=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psbn_d_coo_sparse_mat :: altmp, stat=info)
case default
info = 136
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
end if
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
if (allocated(altmp)) then
call altmp%mv_from_fmt(a%a, info)
else
write(0,*) 'Unallocated altmp??'
info = -1
end if
if (info /= 0) then
info = 4010
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a%a)
call a%set_asb()
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 psbn_d_spcnv_ip