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

*** empty log message ***

Browse Source
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent 00da2086a5
commit cbc36fdd48
6 changed files with 1244 additions and 456 deletions
Show Stats Download Patch File Download Diff File

10
src/modules/psb_serial_mod.f90
Unescape Escape View File

@ -310,22 +310,24 @@ module psb_serial_mod
end interface end interface
interface psb_coins interface psb_coins
subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild) subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_spmat_type use psb_spmat_type
integer, intent(in) :: nz, imin,imax,jmin,jmax integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:),gtl(:) integer, intent(in) :: ia(:),ja(:)
real(kind(1.d0)), intent(in) :: val(:) real(kind(1.d0)), intent(in) :: val(:)
type(psb_dspmat_type), intent(inout) :: a type(psb_dspmat_type), intent(inout) :: a
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
logical, optional, intent(in) :: rebuild logical, optional, intent(in) :: rebuild
end subroutine psb_dcoins end subroutine psb_dcoins
subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild) subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_spmat_type use psb_spmat_type
integer, intent(in) :: nz, imin,imax,jmin,jmax integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:),gtl(:) integer, intent(in) :: ia(:),ja(:)
complex(kind(1.d0)), intent(in) :: val(:) complex(kind(1.d0)), intent(in) :: val(:)
type(psb_zspmat_type), intent(inout) :: a type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
logical, optional, intent(in) :: rebuild logical, optional, intent(in) :: rebuild
end subroutine psb_zcoins end subroutine psb_zcoins
end interface end interface

474
src/serial/psb_dcoins.f90
Unescape Escape View File

@ -31,7 +31,7 @@
! File: psbdcoins.f90 ! File: psbdcoins.f90
! Subroutine: ! Subroutine:
! Parameters: ! Parameters:
subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild) subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_spmat_type use psb_spmat_type
use psb_const_mod use psb_const_mod
@ -43,10 +43,11 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:),gtl(:) integer, intent(in) :: ia(:),ja(:)
real(kind(1.d0)), intent(in) :: val(:) real(kind(1.d0)), intent(in) :: val(:)
type(psb_dspmat_type), intent(inout) :: a type(psb_dspmat_type), intent(inout) :: a
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
logical, intent(in), optional :: rebuild logical, intent(in), optional :: rebuild
character(len=5) :: ufida character(len=5) :: ufida
@ -95,153 +96,312 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild)
end if end if
call touppers(a%fida,ufida) call touppers(a%fida,ufida)
ng = size(gtl)
spstate = psb_sp_getifld(psb_state_,a,info) spstate = psb_sp_getifld(psb_state_,a,info)
select case(spstate)
case(psb_spmat_bld_) if (present(gtl)) then
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 psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then
info=4010
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if ((nza+nz)>isza) then ng = size(gtl)
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) select case(spstate)
case(psb_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 psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then if(info /= izero) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
endif
call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,gtl,ng,& if ((nza+nz)>isza) then
& imin,imax,jmin,jmax,info) call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then if(info /= izero) then
info=4010 info=4010
ch_err='psb_inner_ins' ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
if (debug) then endif
if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items ' call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,&
& imin,imax,jmin,jmax,info,gtl,ng)
if(info /= 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(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items '
end if
end if end if
end if if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then
if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_del_bnd_,a,info) endif
endif call psb_sp_setifld(nza,psb_nnz_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info)
case(psb_spmat_upd_)
iupd = psb_sp_getifld(psb_upd_,a,info)
select case (iupd)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
if (info /= 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+psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items '
end if
end if
a%ia2(ip1+psb_nnz_) = nza
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
case (psb_upd_dflt_, psb_upd_srch_)
call psb_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
if (info > 0) then
if (rebuild_) then
if (debug) write(0,*)&
& 'COINS: Going through rebuild_ fingers crossed!'
irst = info
call psb_nullify_sp(tmp)
tmp%fida='COO'
call psb_csdp(a,tmp,info)
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
endif
call psb_sp_transfer(tmp,a,info)
call psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then
info=4010
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debug) write(0,*)&
& 'COINS: Reinserting',a%fida,nza,isza
if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
endif
if (irst <= nz) then
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),&
& nza,a%ia1,a%ia2,a%aspk,imin,imax,jmin,jmax,info,gtl,ng)
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info)
end if
else
info = 2231
call psb_errpush(info,name)
goto 9999
end if
else if (info < 0) then
info = 2230
call psb_errpush(info,name)
goto 9999
end if
case default
info = 2231
call psb_errpush(info,name)
goto 9999
end select
case default
info = 2232
call psb_errpush(info,name)
goto 9999
end select
case(psb_spmat_upd_)
iupd = psb_sp_getifld(psb_upd_,a,info)
select case (iupd)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
nza = a%ia2(ip1+psb_nnz_) else
nzl = a%infoa(psb_del_bnd_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,ng,& ng = -1
& imin,imax,jmin,jmax,nzl,info)
if (info /= izero) then select case(spstate)
case(psb_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 psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then
info=4010 info=4010
ch_err='psb_inner_upd' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then
info=4010
ch_err='psb_sp_reall'
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,&
& imin,imax,jmin,jmax,info)
if(info /= izero) then
info=4010
ch_err='psb_inner_ins'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items ' write(0,*) 'PSB_COINS: insert discarded items '
end if end if
end if end if
a%ia2(ip1+psb_nnz_) = nza if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
endif
call psb_sp_setifld(nza,psb_nnz_,a,info)
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza case(psb_spmat_upd_)
case (psb_upd_dflt_, psb_upd_srch_) iupd = psb_sp_getifld(psb_upd_,a,info)
select case (iupd)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
call psb_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,&
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,&
& imin,imax,jmin,jmax,nzl,info)
if (info /= 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+psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items '
end if
end if
a%ia2(ip1+psb_nnz_) = nza
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
case (psb_upd_dflt_, psb_upd_srch_)
call psb_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info)
if (info > 0) then
if (rebuild_) then if (info > 0) then
if (debug) write(0,*)& if (rebuild_) then
& 'COINS: Going through rebuild_ fingers crossed!' if (debug) write(0,*)&
irst = info & 'COINS: Going through rebuild_ fingers crossed!'
call psb_nullify_sp(tmp) irst = info
tmp%fida='COO' call psb_nullify_sp(tmp)
call psb_csdp(a,tmp,info) tmp%fida='COO'
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) call psb_csdp(a,tmp,info)
if (debug) then call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst if (debug) then
endif write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
call psb_sp_transfer(tmp,a,info) endif
call psb_spinfo(psb_nztotreq_,a,nza,info) call psb_sp_transfer(tmp,a,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info) call psb_spinfo(psb_nztotreq_,a,nza,info)
if(info /= izero) then call psb_spinfo(psb_nzsizereq_,a,isza,info)
info=4010
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debug) write(0,*)&
& 'COINS: Reinserting',a%fida,nza,isza
if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then if(info /= izero) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
endif
if (irst <= nz) then if (debug) write(0,*)&
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& & 'COINS: Reinserting',a%fida,nza,isza
& nza,a%ia1,a%ia2,a%aspk,gtl,ng,imin,imax,jmin,jmax,info) if ((nza+nz)>isza) then
call psb_sp_setifld(nza,psb_del_bnd_,a,info) call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
call psb_sp_setifld(nza,psb_nnz_,a,info) if(info /= izero) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
endif
if (irst <= nz) then
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),&
& nza,a%ia1,a%ia2,a%aspk,imin,imax,jmin,jmax,info)
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info)
end if
else
info = 2231
call psb_errpush(info,name)
goto 9999
end if end if
else if (info < 0) then
else info = 2230
info = 2231
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
else if (info < 0) then
info = 2230 case default
info = 2231
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end select
end if
case default
info = 2231 case default
info = 2232
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end select end select
endif
case default
info = 2232
call psb_errpush(info,name)
goto 9999
end select
return return
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -257,70 +417,112 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild)
contains contains
subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,gtl,ng,& subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,ng integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza integer, intent(inout) :: nza
real(kind(1.d0)), intent(in) :: val(*) real(kind(1.d0)), intent(in) :: val(*)
real(kind(1.d0)), intent(inout) :: aspk(*) real(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer :: i,ir,ic integer :: i,ir,ic
if (nza >= nzl) then if (present(gtl)) then
do i=1, nz if (.not.present(ng)) then
nza = nza + 1 info = -1
aspk(nza) = val(i) return
end do endif
if (nza >= nzl) then
do i=1, nz
nza = nza + 1
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
aspk(nza) = val(i)
end if
end if
end do
end if
else else
do i=1, nz if (nza >= nzl) then
ir = ia(i) do i=1, nz
ic = ja(i) nza = nza + 1
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then aspk(nza) = val(i)
ir = gtl(ir) end do
ic = gtl(ic) else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1 nza = nza + 1
aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end if end do
end do end if
end if end if
end subroutine psb_inner_upd end subroutine psb_inner_upd
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,gtl,ng,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,&
& imin,imax,jmin,jmax,info) & imin,imax,jmin,jmax,info,gtl,ng)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax,ng integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza,ia1(*),ia2(*) integer, intent(inout) :: nza,ia1(*),ia2(*)
real(kind(1.d0)), intent(in) :: val(*) real(kind(1.d0)), intent(in) :: val(*)
real(kind(1.d0)), intent(inout) :: aspk(*) real(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer :: i,ir,ic integer :: i,ir,ic
info = 0 info = 0
do i=1, nz if (present(gtl)) then
ir = ia(i) if (.not.present(ng)) then
ic = ja(i) info = -1
return
endif
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
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then do i=1, nz
ir = gtl(ir) ir = ia(i)
ic = gtl(ic) ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1 nza = nza + 1
ia1(nza) = ir ia1(nza) = ir
ia2(nza) = ic ia2(nza) = ic
aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end if end do
end do end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
end subroutine psb_dcoins end subroutine psb_dcoins

729
src/serial/psb_update_mod.f90
Unescape Escape View File

@ -51,79 +51,129 @@ module psb_update_mod
contains contains
subroutine psb_d_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& subroutine psb_d_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
type(psb_dspmat_type), intent(inout) :: a type(psb_dspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,ng integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza integer, intent(inout) :: nza
real(kind(1.d0)), intent(in) :: val(*) real(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
info = 0 info = 0
select case(toupper(a%fida)) if (present(gtl)) then
case ('CSR') if (.not.present(ng)) then
info = -1
return
endif
select case(toupper(a%fida))
case ('CSR')
!!$ write(0,*) 'Calling csr_srch_upd' !!$ write(0,*) 'Calling csr_srch_upd'
call csr_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& call csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
!!$ write(0,*) 'From csr_srch_upd:',info !!$ write(0,*) 'From csr_srch_upd:',info
case ('COO') case ('COO')
call coo_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
case default case default
info = -9 info = -9
end select end select
else
select case(toupper(a%fida))
case ('CSR')
!!$ write(0,*) 'Calling csr_srch_upd'
call csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
!!$ write(0,*) 'From csr_srch_upd:',info
case ('COO')
call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
case default
info = -9
end select
end if
end subroutine psb_d_srch_upd end subroutine psb_d_srch_upd
subroutine psb_z_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& subroutine psb_z_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
type(psb_zspmat_type), intent(inout) :: a type(psb_zspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,ng integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza integer, intent(inout) :: nza
complex(kind(1.d0)), intent(in) :: val(*) complex(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
info = 0 info = 0
select case(toupper(a%fida)) if (present(gtl)) then
case ('CSR') if (.not.present(ng)) then
info = -1
return
endif
select case(toupper(a%fida))
case ('CSR')
!!$ write(0,*) 'Calling csr_srch_upd' !!$ write(0,*) 'Calling csr_srch_upd'
call csr_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& call csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
!!$ write(0,*) 'From csr_srch_upd:',info !!$ write(0,*) 'From csr_srch_upd:',info
case ('COO') case ('COO')
call coo_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
case default case default
info = -9 info = -9
end select end select
else
select case(toupper(a%fida))
case ('CSR')
!!$ write(0,*) 'Calling csr_srch_upd'
call csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
!!$ write(0,*) 'From csr_srch_upd:',info
case ('COO')
call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
case default
info = -9
end select
end if
end subroutine psb_z_srch_upd end subroutine psb_z_srch_upd
subroutine d_csr_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& subroutine d_csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
type(psb_dspmat_type), intent(inout) :: a type(psb_dspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,ng integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza integer, intent(inout) :: nza
real(kind(1.d0)), intent(in) :: val(*) real(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer :: i,ir,ic,check_flag, ilr, ilc, ip, & integer :: i,ir,ic,check_flag, ilr, ilc, ip, &
& i1,i2,nc,lb,ub,m,nnz,dupl & i1,i2,nc,lb,ub,m,nnz,dupl
@ -131,19 +181,112 @@ contains
dupl = psb_sp_getifld(psb_dupl_,a,info) dupl = psb_sp_getifld(psb_dupl_,a,info)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_) if (present(gtl)) then
! Overwrite. if (.not.present(ng)) then
! Cannot test for error, should have been caught earlier. info = -1
return
ilr = -1 endif
ilc = -1
do i=1, nz select case(dupl)
ir = ia(i) case(psb_dupl_ovwrt_,psb_dupl_err_)
ic = ja(i) ! Overwrite.
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ! Cannot test for error, should have been caught earlier.
ir = gtl(ir)
ic = gtl(ic) ilr = -1
ilc = -1
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)
i1 = a%ia2(ir)
i2 = a%ia2(ir+1)
nc=i2-i1
if (.true.) then
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
write(0,*)'Was searching ',ic,' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
info = i
return
end if
else
!!$
ip = -1
lb = i1
ub = i2-1
do
if (lb > ub) exit
m = (lb+ub)/2
!!$ write(0,*) 'Debug: ',lb,m,ub
if (ic == a%ia1(m)) then
ip = m
lb = ub + 1
else if (ic < a%ia1(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (ip>0) then
a%aspk(ip) = val(i)
else
write(0,*)'Was searching ',ic,' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
info = i
return
end if
end if
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
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)
i1 = a%ia2(ir)
i2 = a%ia2(ir+1)
nc = i2-i1
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else
info = i
return
end if
end if
end do
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
i1 = a%ia2(ir) i1 = a%ia2(ir)
i2 = a%ia2(ir+1) i2 = a%ia2(ir+1)
nc=i2-i1 nc=i2-i1
@ -187,19 +330,15 @@ contains
end if end if
end if end if
end if end do
end do
case(psb_dupl_add_)
case(psb_dupl_add_) ! Add
! Add ilr = -1
ilr = -1 ilc = -1
ilc = -1 do i=1, nz
do i=1, nz ir = ia(i)
ir = ia(i) ic = ja(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
i1 = a%ia2(ir) i1 = a%ia2(ir)
i2 = a%ia2(ir+1) i2 = a%ia2(ir+1)
nc = i2-i1 nc = i2-i1
@ -210,25 +349,27 @@ contains
info = i info = i
return return
end if end if
end if end do
end do
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select
end if
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select
end subroutine d_csr_srch_upd end subroutine d_csr_srch_upd
subroutine d_coo_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& subroutine d_coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
type(psb_dspmat_type), intent(inout) :: a type(psb_dspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,ng integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza integer, intent(inout) :: nza
real(kind(1.d0)), intent(in) :: val(*) real(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer :: i,ir,ic,check_flag, ilr, ilc, ip, & integer :: i,ir,ic,check_flag, ilr, ilc, ip, &
& i1,i2,nc,lb,ub,m,nnz,dupl,isrt & i1,i2,nc,lb,ub,m,nnz,dupl,isrt
@ -246,16 +387,95 @@ contains
nnz = psb_sp_getifld(psb_nnz_,a,info) nnz = psb_sp_getifld(psb_nnz_,a,info)
select case(dupl) if (present(gtl)) then
case(psb_dupl_ovwrt_,psb_dupl_err_) if (.not.present(ng)) then
! Overwrite. info = -1
! Cannot test for error, should have been caught earlier. return
do i=1, nz endif
ir = ia(i)
ic = ja(i) select case(dupl)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then case(psb_dupl_ovwrt_,psb_dupl_err_)
ir = gtl(ir) ! Overwrite.
ic = gtl(ic) ! Cannot test for error, should have been caught earlier.
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 /= ilr) then
call ibsrch(i1,ir,nnz,a%ia1)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia1(i2+1) /= a%ia1(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia1(i1-1) /= a%ia1(i1)) exit
i1 = i1 - 1
end do
ilr = ir
end if
nc = i2-i1+1
call issrch(ip,ic,nc,a%ia2(i1:i2))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
info = i
return
end if
end if
end do
case(psb_dupl_add_)
! Add
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 /= ilr) then
call ibsrch(i1,ir,nnz,a%ia1)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia1(i2+1) /= a%ia1(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia1(i1-1) /= a%ia1(i1)) exit
i1 = i1 - 1
end do
ilr = ir
end if
nc = i2-i1+1
call issrch(ip,ic,nc,a%ia2(i1:i2))
if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else
info = i
return
end if
end if
end do
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
do i=1, nz
ir = ia(i)
ic = ja(i)
if (ir /= ilr) then if (ir /= ilr) then
call ibsrch(i1,ir,nnz,a%ia1) call ibsrch(i1,ir,nnz,a%ia1)
i2 = i1 i2 = i1
@ -279,16 +499,13 @@ contains
info = i info = i
return return
end if end if
end if end do
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(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 /= ilr) then if (ir /= ilr) then
call ibsrch(i1,ir,nnz,a%ia1) call ibsrch(i1,ir,nnz,a%ia1)
i2 = i1 i2 = i1
@ -312,28 +529,30 @@ contains
info = i info = i
return return
end if end if
end if end do
end do
case default case default
info = -3 info = -3
write(0,*) 'Duplicate handling: ',dupl write(0,*) 'Duplicate handling: ',dupl
end select end select
end subroutine d_coo_srch_upd end if
end subroutine d_coo_srch_upd
subroutine z_csr_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& subroutine z_csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
type(psb_zspmat_type), intent(inout) :: a type(psb_zspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,ng integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza integer, intent(inout) :: nza
complex(kind(1.d0)), intent(in) :: val(*) complex(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer :: i,ir,ic,check_flag, ilr, ilc, ip, & integer :: i,ir,ic,check_flag, ilr, ilc, ip, &
& i1,i2,nc,lb,ub,m,nnz,dupl & i1,i2,nc,lb,ub,m,nnz,dupl
@ -341,19 +560,112 @@ contains
dupl = psb_sp_getifld(psb_dupl_,a,info) dupl = psb_sp_getifld(psb_dupl_,a,info)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_) if (present(gtl)) then
! Overwrite. if (.not.present(ng)) then
! Cannot test for error, should have been caught earlier. info = -1
return
ilr = -1 endif
ilc = -1
do i=1, nz select case(dupl)
ir = ia(i) case(psb_dupl_ovwrt_,psb_dupl_err_)
ic = ja(i) ! Overwrite.
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ! Cannot test for error, should have been caught earlier.
ir = gtl(ir)
ic = gtl(ic) ilr = -1
ilc = -1
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)
i1 = a%ia2(ir)
i2 = a%ia2(ir+1)
nc=i2-i1
if (.true.) then
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
write(0,*)'Was searching ',ic,' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
info = i
return
end if
else
!!$
ip = -1
lb = i1
ub = i2-1
do
if (lb > ub) exit
m = (lb+ub)/2
!!$ write(0,*) 'Debug: ',lb,m,ub
if (ic == a%ia1(m)) then
ip = m
lb = ub + 1
else if (ic < a%ia1(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (ip>0) then
a%aspk(ip) = val(i)
else
write(0,*)'Was searching ',ic,' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
info = i
return
end if
end if
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
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)
i1 = a%ia2(ir)
i2 = a%ia2(ir+1)
nc = i2-i1
call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else
info = i
return
end if
end if
end do
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
i1 = a%ia2(ir) i1 = a%ia2(ir)
i2 = a%ia2(ir+1) i2 = a%ia2(ir+1)
nc=i2-i1 nc=i2-i1
@ -397,19 +709,15 @@ contains
end if end if
end if end if
end if end do
end do
case(psb_dupl_add_)
case(psb_dupl_add_) ! Add
! Add ilr = -1
ilr = -1 ilc = -1
ilc = -1 do i=1, nz
do i=1, nz ir = ia(i)
ir = ia(i) ic = ja(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
i1 = a%ia2(ir) i1 = a%ia2(ir)
i2 = a%ia2(ir+1) i2 = a%ia2(ir+1)
nc = i2-i1 nc = i2-i1
@ -420,25 +728,27 @@ contains
info = i info = i
return return
end if end if
end if end do
end do
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select
end if
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select
end subroutine z_csr_srch_upd end subroutine z_csr_srch_upd
subroutine z_coo_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& subroutine z_coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
type(psb_zspmat_type), intent(inout) :: a type(psb_zspmat_type), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,ng integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza integer, intent(inout) :: nza
complex(kind(1.d0)), intent(in) :: val(*) complex(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer :: i,ir,ic,check_flag, ilr, ilc, ip, & integer :: i,ir,ic,check_flag, ilr, ilc, ip, &
& i1,i2,nc,lb,ub,m,nnz,dupl,isrt & i1,i2,nc,lb,ub,m,nnz,dupl,isrt
@ -456,16 +766,95 @@ contains
nnz = psb_sp_getifld(psb_nnz_,a,info) nnz = psb_sp_getifld(psb_nnz_,a,info)
select case(dupl) if (present(gtl)) then
case(psb_dupl_ovwrt_,psb_dupl_err_) if (.not.present(ng)) then
! Overwrite. info = -1
! Cannot test for error, should have been caught earlier. return
do i=1, nz endif
ir = ia(i)
ic = ja(i) select case(dupl)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then case(psb_dupl_ovwrt_,psb_dupl_err_)
ir = gtl(ir) ! Overwrite.
ic = gtl(ic) ! Cannot test for error, should have been caught earlier.
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 /= ilr) then
call ibsrch(i1,ir,nnz,a%ia1)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia1(i2+1) /= a%ia1(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia1(i1-1) /= a%ia1(i1)) exit
i1 = i1 - 1
end do
ilr = ir
end if
nc = i2-i1+1
call issrch(ip,ic,nc,a%ia2(i1:i2))
if (ip>0) then
a%aspk(i1+ip-1) = val(i)
else
info = i
return
end if
end if
end do
case(psb_dupl_add_)
! Add
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 /= ilr) then
call ibsrch(i1,ir,nnz,a%ia1)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia1(i2+1) /= a%ia1(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia1(i1-1) /= a%ia1(i1)) exit
i1 = i1 - 1
end do
ilr = ir
end if
nc = i2-i1+1
call issrch(ip,ic,nc,a%ia2(i1:i2))
if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else
info = i
return
end if
end if
end do
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
do i=1, nz
ir = ia(i)
ic = ja(i)
if (ir /= ilr) then if (ir /= ilr) then
call ibsrch(i1,ir,nnz,a%ia1) call ibsrch(i1,ir,nnz,a%ia1)
i2 = i1 i2 = i1
@ -476,7 +865,6 @@ contains
end do end do
do do
if (i1-1 < 1) exit if (i1-1 < 1) exit
if (a%ia1(i1-1) /= a%ia1(i1)) exit if (a%ia1(i1-1) /= a%ia1(i1)) exit
i1 = i1 - 1 i1 = i1 - 1
end do end do
@ -487,19 +875,16 @@ contains
if (ip>0) then if (ip>0) then
a%aspk(i1+ip-1) = val(i) a%aspk(i1+ip-1) = val(i)
else else
info = i info = i
return return
end if end if
end if end do
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(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 /= ilr) then if (ir /= ilr) then
call ibsrch(i1,ir,nnz,a%ia1) call ibsrch(i1,ir,nnz,a%ia1)
i2 = i1 i2 = i1
@ -520,19 +905,19 @@ contains
if (ip>0) then if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else else
info = i info = i
return return
end if end if
end if end do
end do
case default case default
info = -3 info = -3
write(0,*) 'Duplicate handling: ',dupl write(0,*) 'Duplicate handling: ',dupl
end select end select
end subroutine z_coo_srch_upd end if
end subroutine z_coo_srch_upd
end module psb_update_mod end module psb_update_mod

475
src/serial/psb_zcoins.f90
Unescape Escape View File

@ -31,7 +31,7 @@
! File: psbzcoins.f90 ! File: psbzcoins.f90
! Subroutine: ! Subroutine:
! Parameters: ! Parameters:
subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild) subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_spmat_type use psb_spmat_type
use psb_const_mod use psb_const_mod
@ -43,11 +43,12 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:),gtl(:) integer, intent(in) :: ia(:),ja(:)
complex(kind(1.d0)), intent(in) :: val(:) complex(kind(1.d0)), intent(in) :: val(:)
type(psb_zspmat_type), intent(inout) :: a type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info integer, intent(out) :: info
logical, optional, intent(in) :: rebuild integer, intent(in), optional :: gtl(:)
logical, intent(in), optional :: rebuild
character(len=5) :: ufida character(len=5) :: ufida
integer :: i,j,ir,ic,nr,nc, ng, nza, isza,spstate, nnz,& integer :: i,j,ir,ic,nr,nc, ng, nza, isza,spstate, nnz,&
@ -95,153 +96,312 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild)
end if end if
call touppers(a%fida,ufida) call touppers(a%fida,ufida)
ng = size(gtl)
spstate = psb_sp_getifld(psb_state_,a,info) spstate = psb_sp_getifld(psb_state_,a,info)
select case(spstate)
case(psb_spmat_bld_) if (present(gtl)) then
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 psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then
info=4010
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if ((nza+nz)>isza) then ng = size(gtl)
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) select case(spstate)
case(psb_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 psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then if(info /= izero) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
endif
call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,gtl,ng,& if ((nza+nz)>isza) then
& imin,imax,jmin,jmax,info) call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then if(info /= izero) then
info=4010 info=4010
ch_err='psb_inner_ins' ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
if (debug) then endif
if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items ' call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,&
& imin,imax,jmin,jmax,info,gtl,ng)
if(info /= 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(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items '
end if
end if end if
end if if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then
if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_del_bnd_,a,info) endif
endif call psb_sp_setifld(nza,psb_nnz_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info)
case(psb_spmat_upd_)
iupd = psb_sp_getifld(psb_upd_,a,info)
select case (iupd)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
if (info /= 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+psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items '
end if
end if
a%ia2(ip1+psb_nnz_) = nza
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
case (psb_upd_dflt_, psb_upd_srch_)
call psb_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
if (info > 0) then
if (rebuild_) then
if (debug) write(0,*)&
& 'COINS: Going through rebuild_ fingers crossed!'
irst = info
call psb_nullify_sp(tmp)
tmp%fida='COO'
call psb_csdp(a,tmp,info)
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
endif
call psb_sp_transfer(tmp,a,info)
call psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then
info=4010
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debug) write(0,*)&
& 'COINS: Reinserting',a%fida,nza,isza
if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
endif
if (irst <= nz) then
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),&
& nza,a%ia1,a%ia2,a%aspk,imin,imax,jmin,jmax,info,gtl,ng)
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info)
end if
else
info = 2231
call psb_errpush(info,name)
goto 9999
end if
else if (info < 0) then
info = 2230
call psb_errpush(info,name)
goto 9999
end if
case default
info = 2231
call psb_errpush(info,name)
goto 9999
end select
case default
info = 2232
call psb_errpush(info,name)
goto 9999
end select
case(psb_spmat_upd_)
iupd = psb_sp_getifld(psb_upd_,a,info)
select case (iupd)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
nza = a%ia2(ip1+psb_nnz_)
nzl = a%infoa(psb_del_bnd_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,ng,& else
& imin,imax,jmin,jmax,nzl,info)
ng = -1
if (info /= izero) then select case(spstate)
case(psb_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 psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then
info=4010
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then
info=4010
ch_err='psb_sp_reall'
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,&
& imin,imax,jmin,jmax,info)
if(info /= izero) then
info=4010 info=4010
ch_err='psb_inner_upd' ch_err='psb_inner_ins'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items ' write(0,*) 'PSB_COINS: insert discarded items '
end if end if
end if end if
a%ia2(ip1+psb_nnz_) = nza if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
endif
call psb_sp_setifld(nza,psb_nnz_,a,info)
case(psb_spmat_upd_)
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza iupd = psb_sp_getifld(psb_upd_,a,info)
select case (iupd)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
case (psb_upd_dflt_, psb_upd_srch_)
call psb_srch_upd(nz,ia,ja,val,nza,a,gtl,ng,& call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info)
if (info > 0) then
if (rebuild_) then if (info /= izero) then
if (debug) write(0,*)& info=4010
& 'COINS: Going through rebuild_ fingers crossed!' ch_err='psb_inner_upd'
irst = info call psb_errpush(info,name,a_err=ch_err)
call psb_nullify_sp(tmp) goto 9999
tmp%fida='COO' endif
call psb_csdp(a,tmp,info) if (debug) then
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then
if (debug) then write(0,*) 'PSB_COINS: update discarded items '
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst end if
endif end if
call psb_sp_transfer(tmp,a,info) a%ia2(ip1+psb_nnz_) = nza
call psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info) if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
if(info /= izero) then
info=4010 case (psb_upd_dflt_, psb_upd_srch_)
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_srch_upd(nz,ia,ja,val,nza,a,&
goto 9999 & imin,imax,jmin,jmax,nzl,info)
endif
if (info > 0) then
if (debug) write(0,*)& if (rebuild_) then
& 'COINS: Reinserting',a%fida,nza,isza if (debug) write(0,*)&
if ((nza+nz)>isza) then & 'COINS: Going through rebuild_ fingers crossed!'
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) irst = info
call psb_nullify_sp(tmp)
tmp%fida='COO'
call psb_csdp(a,tmp,info)
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
endif
call psb_sp_transfer(tmp,a,info)
call psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then if(info /= izero) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
endif
if (irst <= nz) then if (debug) write(0,*)&
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& & 'COINS: Reinserting',a%fida,nza,isza
& nza,a%ia1,a%ia2,a%aspk,gtl,ng,imin,imax,jmin,jmax,info) if ((nza+nz)>isza) then
call psb_sp_setifld(nza,psb_del_bnd_,a,info) call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
call psb_sp_setifld(nza,psb_nnz_,a,info) if(info /= izero) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
endif
if (irst <= nz) then
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),&
& nza,a%ia1,a%ia2,a%aspk,imin,imax,jmin,jmax,info)
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info)
end if
else
info = 2231
call psb_errpush(info,name)
goto 9999
end if end if
else if (info < 0) then
else info = 2230
info = 2231
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
else if (info < 0) then
info = 2230 case default
info = 2231
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end select
end if
case default
info = 2231 case default
info = 2232
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end select end select
endif
case default
info = 2232
call psb_errpush(info,name)
goto 9999
end select
return return
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -257,69 +417,108 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info,rebuild)
contains contains
subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,gtl,ng,& subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,ng integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza integer, intent(inout) :: nza
complex(kind(1.d0)), intent(in) :: val(*) complex(kind(1.d0)), intent(in) :: val(*)
complex(kind(1.d0)), intent(inout) :: aspk(*) complex(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer :: i,ir,ic integer :: i,ir,ic
if (nza >= nzl) then if (present(gtl)) then
do i=1, nz if (.not.present(ng)) then
nza = nza + 1 info = -1
aspk(nza) = val(i) return
end do endif
if (nza >= nzl) then
do i=1, nz
nza = nza + 1
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
aspk(nza) = val(i)
end if
end if
end do
end if
else else
do i=1, nz if (nza >= nzl) then
ir = ia(i) do i=1, nz
ic = ja(i) nza = nza + 1
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then aspk(nza) = val(i)
ir = gtl(ir) end do
ic = gtl(ic) else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1 nza = nza + 1
aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end if end do
end do end if
end if end if
end subroutine psb_inner_upd end subroutine psb_inner_upd
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,gtl,ng,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,&
& imin,imax,jmin,jmax,info) & imin,imax,jmin,jmax,info,gtl,ng)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax,ng integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(*),ja(*),gtl(*) integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza,ia1(*),ia2(*) integer, intent(inout) :: nza,ia1(*),ia2(*)
complex(kind(1.d0)), intent(in) :: val(*) complex(kind(1.d0)), intent(in) :: val(*)
complex(kind(1.d0)), intent(inout) :: aspk(*) complex(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer :: i,ir,ic integer :: i,ir,ic
info = 0 info = 0
do i=1, nz if (present(gtl)) then
ir = ia(i) if (.not.present(ng)) then
ic = ja(i) info = -1
return
endif
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
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then do i=1, nz
ir = gtl(ir) ir = ia(i)
ic = gtl(ic) ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1 nza = nza + 1
ia1(nza) = ir ia1(nza) = ir
ia2(nza) = ic ia2(nza) = ic
aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end if end do
end do end if
end subroutine psb_inner_ins end subroutine psb_inner_ins

6
src/tools/psb_dspins.f90
Unescape Escape View File

@ -145,7 +145,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
ncol = desc_a%matrix_data(psb_n_col_) ncol = desc_a%matrix_data(psb_n_col_)
if (spstate == psb_spmat_bld_) then if (spstate == psb_spmat_bld_) then
call psb_coins(nz,ia,ja,val,a,desc_a%glob_to_loc,1,nrow,1,ncol,info) call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%glob_to_loc)
if (info /= 0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_coins' ch_err='psb_coins'
@ -160,8 +160,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
else if (psb_is_asb_dec(dectype)) then else if (psb_is_asb_dec(dectype)) then
nrow = desc_a%matrix_data(psb_n_row_) nrow = desc_a%matrix_data(psb_n_row_)
ncol = desc_a%matrix_data(psb_n_col_) ncol = desc_a%matrix_data(psb_n_col_)
call psb_coins(nz,ia,ja,val,a,desc_a%glob_to_loc,1,nrow,1,ncol,& call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,&
& info,rebuild=rebuild_) & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_)
if (info /= 0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_coins' ch_err='psb_coins'

6
src/tools/psb_zspins.f90
Unescape Escape View File

@ -145,7 +145,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
ncol = desc_a%matrix_data(psb_n_col_) ncol = desc_a%matrix_data(psb_n_col_)
if (spstate == psb_spmat_bld_) then if (spstate == psb_spmat_bld_) then
call psb_coins(nz,ia,ja,val,a,desc_a%glob_to_loc,1,nrow,1,ncol,info) call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%glob_to_loc)
if (info /= 0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_coins' ch_err='psb_coins'
@ -160,8 +160,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
else if (psb_is_asb_dec(dectype)) then else if (psb_is_asb_dec(dectype)) then
nrow = desc_a%matrix_data(psb_n_row_) nrow = desc_a%matrix_data(psb_n_row_)
ncol = desc_a%matrix_data(psb_n_col_) ncol = desc_a%matrix_data(psb_n_col_)
call psb_coins(nz,ia,ja,val,a,desc_a%glob_to_loc,1,nrow,1,ncol,& call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,&
& info,rebuild=rebuild_) & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_)
if (info /= 0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_coins' ch_err='psb_coins'

Write Preview
Loading…
Cancel
Save