fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Remove psbdcoins.f90.

Browse Source
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent f25c92b8bd
commit 70866a9445
2 changed files with 26 additions and 245 deletions
Show Stats Download Patch File Download Diff File

51
src/serial/psb_dneigh.f90
Unescape Escape View File

@ -70,31 +70,6 @@ subroutine psb_dneigh(a,idx,neigh,n,info,lev)
contains
subroutine psb_dneigh1l(a,idx,neigh,n)
use psb_realloc_mod
use psb_const_mod
use psb_spmat_type
implicit none
type(psb_dspmat_type), intent(in) :: a ! the sparse matrix
integer, intent(in) :: idx ! the index whose neighbours we want to find
integer, intent(out) :: n ! the number of neighbours and the info
integer, pointer :: neigh(:) ! the neighbours
select case(a%fida(1:3))
case('CSR')
call csr_dneigh1l(a,idx,neigh,n)
case('COO')
call coo_dneigh1l(a,idx,neigh,n)
case('JAD')
call jad_dneigh1l(a,idx,neigh,n)
end select
end subroutine psb_dneigh1l
subroutine csr_dneigh1l(a,idx,neigh,n)
use psb_realloc_mod
@ -280,5 +255,31 @@ contains
end subroutine jad_dneigh1l
subroutine psb_dneigh1l(a,idx,neigh,n)
use psb_realloc_mod
use psb_const_mod
use psb_spmat_type
use psb_string_mod
implicit none
type(psb_dspmat_type), intent(in) :: a ! the sparse matrix
integer, intent(in) :: idx ! the index whose neighbours we want to find
integer, intent(out) :: n ! the number of neighbours and the info
integer, pointer :: neigh(:) ! the neighbours
select case(toupper(a%fida(1:3)))
case('CSR')
call csr_dneigh1l(a,idx,neigh,n)
case('COO')
call coo_dneigh1l(a,idx,neigh,n)
case('JAD')
call jad_dneigh1l(a,idx,neigh,n)
end select
end subroutine psb_dneigh1l
end subroutine psb_dneigh

220
src/serial/psbdcoins.f90
Unescape Escape View File

@ -1,220 +0,0 @@
! File: psbdcoins.f90
! Subroutine:
! Parameters:
subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
use typesp
use tools_const
use realloc
use string
use errormod
use f90serial, only : spinfo
implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:),gtl(:)
real(kind(1.d0)), intent(in) :: val(:)
type(d_spmat), intent(inout) :: a
integer, intent(out) :: info
character(len=5) :: ufida
integer :: i,j,ir,ic,nr,nc, ng, nza, isza,spstate, nnz,&
& ip1, nzl, err_act, int_err(5)
integer, parameter :: izero=0
logical, parameter :: debug=.true.
character(len=20) :: name, ch_err
name='psbdcoins'
info = 0
call psb_erractionsave(err_act)
info = 0
if (nz <= 0) then
info = 10
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(ia) < nz) then
info = 35
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(ja) < nz) then
info = 35
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(val) < nz) then
info = 35
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
!!$ ufida = toupper(a%fida)
call touppers(a%fida,ufida)
ng = size(gtl)
spstate = a%infoa(state_)
select case(spstate)
case(spmat_bld)
if ((ufida /= 'COO').and.(ufida/='COI')) then
info = 134
ch_err(1:3)=ufida(1:3)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call spinfo(nztotreq,a,nza,info)
call spinfo(nzsizereq,a,isza,info)
if(info.ne.izero) then
info=4010
ch_err='spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if ((nza+nz)>isza) then
call spreall(a,nza+nz,info)
if(info.ne.izero) then
info=4010
ch_err='spreall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
endif
call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,gtl,&
& imin,imax,jmin,jmax,info)
if(info.ne.izero) then
info=4010
ch_err='psb_inner_ins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debug) then
if ((nza - a%infoa(nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items '
end if
end if
if ((nza - a%infoa(nnz_)) /= nz) then
a%infoa(del_bnd_) = nza
endif
a%infoa(nnz_) = nza
case(spmat_upd)
if (ibits(a%infoa(upd_),2,1).eq.1) then
ip1 = a%infoa(upd_pnt_)
nza = a%ia2(ip1+nnz_)
nzl = a%infoa(del_bnd_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,&
& imin,imax,jmin,jmax,nzl,info)
if(info.ne.izero) then
info=4010
ch_err='psb_inner_upd'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
!!$ if (debug) then
!!$ if ((nza - a%ia2(ip1+nnz_)) /= nz) then
!!$ write(0,*) 'PSB_COINS: update discarded items '
!!$ end if
!!$ end if
a%ia2(ip1+nnz_) = nza
else
info = 2231
goto 9999
endif
case default
info = 2232
call psb_errpush(info,name)
goto 9999
end select
return
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error()
return
end if
return
contains
subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,gtl,imin,imax,jmin,jmax,nzl,info)
implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*)
integer, intent(inout) :: nza
real(kind(1.d0)), intent(in) :: val(*)
real(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info
integer :: i,ir,ic
info = 0
if (nza >= nzl) then
do i=1, nz
nza = nza + 1
a%aspk(nza) = val(i)
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
a%aspk(nza) = val(i)
end if
end if
end do
end if
end subroutine psb_inner_upd
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,gtl,&
& imin,imax,jmin,jmax,info)
implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(*),ja(*),gtl(*)
integer, intent(inout) :: nza,ia1(*),ia2(*)
real(kind(1.d0)), intent(in) :: val(*)
real(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info
integer :: i,ir,ic
info = 0
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
a%ia1(nza) = ir
a%ia2(nza) = ic
a%aspk(nza) = val(i)
end if
end if
end do
end subroutine psb_inner_ins
end subroutine psb_dcoins
Write Preview
Loading…
Cancel
Save