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 df830a0b84
commit f1de4b3561
9 changed files with 164 additions and 58 deletions
Show Stats Download Patch File Download Diff File

2
src/modules/psb_error_mod.f90
Unescape Escape View File

@ -441,6 +441,8 @@ contains
write (0,'("Error from call to a subroutine ")') write (0,'("Error from call to a subroutine ")')
case(4012) case(4012)
write (0,'("Error ",i0," from call to a subroutine ")')i_e_d(1) write (0,'("Error ",i0," from call to a subroutine ")')i_e_d(1)
case(4013)
write (0,'("Error from call to subroutine ",a," ",i0)')a_e_d,i_e_d(1)
case(4110) case(4110)
write (0,'("Error ",i0," from call to an external package in subroutine ",a)')i_e_d(1),a_e_d write (0,'("Error ",i0," from call to an external package in subroutine ",a)')i_e_d(1),a_e_d
case (5001) case (5001)

2
src/prec/psb_dmlprc_bld.f90
Unescape Escape View File

@ -45,7 +45,7 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
implicit none implicit none
type(psb_dspmat_type), intent(in), target :: a type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in), target :: desc_a
type(psb_dbaseprc_type), intent(inout) :: p type(psb_dbaseprc_type), intent(inout) :: p
integer, intent(out) :: info integer, intent(out) :: info

6
src/prec/psb_dprecbld.f90
Unescape Escape View File

@ -58,7 +58,7 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
Use psb_spmat_type Use psb_spmat_type
use psb_descriptor_type use psb_descriptor_type
use psb_prec_type use psb_prec_type
type(psb_dspmat_type), target :: a type(psb_dspmat_type) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
type(psb_dbaseprc_type),intent(inout) :: p type(psb_dbaseprc_type),intent(inout) :: p
integer, intent(out) :: info integer, intent(out) :: info
@ -74,8 +74,8 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
use psb_const_mod use psb_const_mod
implicit none implicit none
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in), target :: desc_a
type(psb_dbaseprc_type), intent(inout) :: p type(psb_dbaseprc_type), intent(inout) :: p
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_dmlprc_bld end subroutine psb_dmlprc_bld

2
src/prec/psb_zmlprc_bld.f90
Unescape Escape View File

@ -45,7 +45,7 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
implicit none implicit none
type(psb_zspmat_type), intent(in), target :: a type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in), target :: desc_a
type(psb_zbaseprc_type), intent(inout) :: p type(psb_zbaseprc_type), intent(inout) :: p
integer, intent(out) :: info integer, intent(out) :: info

4
src/prec/psb_zprecbld.f90
Unescape Escape View File

@ -74,8 +74,8 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
use psb_const_mod use psb_const_mod
implicit none implicit none
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in), target :: desc_a
type(psb_zbaseprc_type), intent(inout) :: p type(psb_zbaseprc_type), intent(inout) :: p
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_zmlprc_bld end subroutine psb_zmlprc_bld

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

@ -130,12 +130,13 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,&
& min(size(a%ia1),size(a%ia2),size(a%aspk)),&
& imin,imax,jmin,jmax,info,gtl,ng) & imin,imax,jmin,jmax,info,gtl,ng)
if(info /= izero) then if(info /= izero) then
info=4010
ch_err='psb_inner_ins' ch_err='psb_inner_ins'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
@ -158,13 +159,12 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
nza = a%ia2(ip1+psb_nnz_) nza = a%ia2(ip1+psb_nnz_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,& call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),&
& imin,imax,jmin,jmax,nzl,info,gtl,ng) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
if (info /= izero) then if (info /= izero) then
info=4010
ch_err='psb_inner_upd' ch_err='psb_inner_upd'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
@ -189,11 +189,23 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
call psb_nullify_sp(tmp) call psb_nullify_sp(tmp)
tmp%fida='COO' tmp%fida='COO'
call psb_csdp(a,tmp,info) call psb_csdp(a,tmp,info)
if(info /= izero) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
endif endif
call psb_sp_transfer(tmp,a,info) call psb_sp_transfer(tmp,a,info)
if(info /= izero) then
info=4010
ch_err='psb_sp_transfer'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_spinfo(psb_nztotreq_,a,nza,info) call psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info) call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then if(info /= izero) then
@ -204,7 +216,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
if (debug) write(0,*)& if (debug) write(0,*)&
& 'COINS: Reinserting',a%fida,nza,isza & 'COINS: Reinserting',a%fida,nza,isza,irst,nz
if ((nza+nz)>isza) then if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then if(info /= izero) then
@ -216,7 +228,14 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
if (irst <= nz) then if (irst <= nz) then
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& 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) & nza,a%ia1,a%ia2,a%aspk,&
& min(size(a%ia1),size(a%ia2),size(a%aspk)),&
&imin,imax,jmin,jmax,info,gtl,ng)
if (info /= izero) then
ch_err='psb_inner_ins'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
endif
call psb_sp_setifld(nza,psb_del_bnd_,a,info) call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info) call psb_sp_setifld(nza,psb_nnz_,a,info)
end if end if
@ -283,12 +302,13 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,&
& min(size(a%ia1),size(a%ia2),size(a%aspk)),&
& imin,imax,jmin,jmax,info) & imin,imax,jmin,jmax,info)
if(info /= izero) then if(info /= izero) then
info=4010
ch_err='psb_inner_ins' ch_err='psb_inner_ins'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
@ -298,6 +318,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
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)
!!$ write(0,*) 'Settind del_bnd_ 2: ',nza
endif endif
call psb_sp_setifld(nza,psb_nnz_,a,info) call psb_sp_setifld(nza,psb_nnz_,a,info)
@ -311,15 +332,14 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
nza = a%ia2(ip1+psb_nnz_) nza = a%ia2(ip1+psb_nnz_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,& call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info)
if (info /= izero) then if (info /= izero) then
info=4010
ch_err='psb_inner_upd' ch_err='psb_inner_upd'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items ' write(0,*) 'PSB_COINS: update discarded items '
@ -369,7 +389,14 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
if (irst <= nz) then if (irst <= nz) then
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& 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) & nza,a%ia1,a%ia2,a%aspk,&
& min(size(a%ia1),size(a%ia2),size(a%aspk)),&
& imin,imax,jmin,jmax,info)
if (info /= izero) then
ch_err='psb_inner_ins'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
endif
call psb_sp_setifld(nza,psb_del_bnd_,a,info) call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info) call psb_sp_setifld(nza,psb_nnz_,a,info)
end if end if
@ -388,7 +415,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
case default case default
info = 2231 info = 2233
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end select end select
@ -417,11 +444,11 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
contains contains
subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,& subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,maxsz,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,maxsz
integer, intent(in) :: ia(*),ja(*) 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(*)
@ -435,9 +462,14 @@ contains
info = -1 info = -1
return return
endif endif
if (nza >= nzl) then if ((nza > nzl)) then
do i=1, nz do i=1, nz
nza = nza + 1 nza = nza + 1
if (nza>maxsz) then
write(0,*) 'Out of bounds in INNER_UPD ',nza,maxsz
info = -71
return
endif
aspk(nza) = val(i) aspk(nza) = val(i)
end do end do
else else
@ -449,15 +481,23 @@ contains
ic = gtl(ic) ic = gtl(ic)
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
if (nza>maxsz) then
info = -72
return
endif
aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end if end if
end do end do
end if end if
else else
if (nza >= nzl) then if ((nza >= nzl)) then
do i=1, nz do i=1, nz
nza = nza + 1 nza = nza + 1
if (nza>maxsz) then
info = -73
return
endif
aspk(nza) = val(i) aspk(nza) = val(i)
end do end do
else else
@ -466,6 +506,10 @@ contains
ic = ja(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
if (nza>maxsz) then
info = -74
return
endif
aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end do end do
@ -473,11 +517,11 @@ contains
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,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl,ng) & imin,imax,jmin,jmax,info,gtl,ng)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz
integer, intent(in) :: ia(*),ja(*) 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(*)
@ -500,6 +544,10 @@ contains
ic = gtl(ic) ic = gtl(ic)
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
if (nza > maxsz) then
info = -91
return
endif
ia1(nza) = ir ia1(nza) = ir
ia2(nza) = ic ia2(nza) = ic
aspk(nza) = val(i) aspk(nza) = val(i)
@ -513,6 +561,10 @@ contains
ic = ja(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
if (nza > maxsz) then
info = -92
return
endif
ia1(nza) = ir ia1(nza) = ir
ia2(nza) = ic ia2(nza) = ic
aspk(nza) = val(i) aspk(nza) = val(i)

2
src/serial/psb_dspgtrow.f90
Unescape Escape View File

@ -60,7 +60,7 @@ subroutine psb_dspgtrow(irw,a,b,info,append,iren,lrw)
integer :: i,j,k,ip,jp,nr,idx, nz,iret,nzb, nza, lrw_, irw_, err_act integer :: i,j,k,ip,jp,nr,idx, nz,iret,nzb, nza, lrw_, irw_, err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dspgtrow' name='psb_spgtrow'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)

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

@ -130,12 +130,13 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,&
& min(size(a%ia1),size(a%ia2),size(a%aspk)),&
& imin,imax,jmin,jmax,info,gtl,ng) & imin,imax,jmin,jmax,info,gtl,ng)
if(info /= izero) then if(info /= izero) then
info=4010
ch_err='psb_inner_ins' ch_err='psb_inner_ins'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
@ -158,13 +159,12 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
nza = a%ia2(ip1+psb_nnz_) nza = a%ia2(ip1+psb_nnz_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,& call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),&
& imin,imax,jmin,jmax,nzl,info,gtl,ng) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
if (info /= izero) then if (info /= izero) then
info=4010
ch_err='psb_inner_upd' ch_err='psb_inner_upd'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
@ -189,11 +189,23 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
call psb_nullify_sp(tmp) call psb_nullify_sp(tmp)
tmp%fida='COO' tmp%fida='COO'
call psb_csdp(a,tmp,info) call psb_csdp(a,tmp,info)
if(info /= izero) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
endif endif
call psb_sp_transfer(tmp,a,info) call psb_sp_transfer(tmp,a,info)
if(info /= izero) then
info=4010
ch_err='psb_sp_transfer'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_spinfo(psb_nztotreq_,a,nza,info) call psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info) call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info /= izero) then if(info /= izero) then
@ -204,7 +216,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
if (debug) write(0,*)& if (debug) write(0,*)&
& 'COINS: Reinserting',a%fida,nza,isza & 'COINS: Reinserting',a%fida,nza,isza,irst,nz
if ((nza+nz)>isza) then if ((nza+nz)>isza) then
call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info /= izero) then if(info /= izero) then
@ -216,7 +228,14 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
if (irst <= nz) then if (irst <= nz) then
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& 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) & nza,a%ia1,a%ia2,a%aspk,&
& min(size(a%ia1),size(a%ia2),size(a%aspk)),&
&imin,imax,jmin,jmax,info,gtl,ng)
if (info /= izero) then
ch_err='psb_inner_ins'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
endif
call psb_sp_setifld(nza,psb_del_bnd_,a,info) call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info) call psb_sp_setifld(nza,psb_nnz_,a,info)
end if end if
@ -283,12 +302,13 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,&
& min(size(a%ia1),size(a%ia2),size(a%aspk)),&
& imin,imax,jmin,jmax,info) & imin,imax,jmin,jmax,info)
if(info /= izero) then if(info /= izero) then
info=4010
ch_err='psb_inner_ins' ch_err='psb_inner_ins'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
@ -298,6 +318,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
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)
!!$ write(0,*) 'Settind del_bnd_ 2: ',nza
endif endif
call psb_sp_setifld(nza,psb_nnz_,a,info) call psb_sp_setifld(nza,psb_nnz_,a,info)
@ -311,15 +332,14 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
nza = a%ia2(ip1+psb_nnz_) nza = a%ia2(ip1+psb_nnz_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,& call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),&
& imin,imax,jmin,jmax,nzl,info) & imin,imax,jmin,jmax,nzl,info)
if (info /= izero) then if (info /= izero) then
info=4010
ch_err='psb_inner_upd' ch_err='psb_inner_upd'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
endif endif
if (debug) then if (debug) then
if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: update discarded items ' write(0,*) 'PSB_COINS: update discarded items '
@ -369,7 +389,14 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif endif
if (irst <= nz) then if (irst <= nz) then
call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& 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) & nza,a%ia1,a%ia2,a%aspk,&
& min(size(a%ia1),size(a%ia2),size(a%aspk)),&
& imin,imax,jmin,jmax,info)
if (info /= izero) then
ch_err='psb_inner_ins'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
endif
call psb_sp_setifld(nza,psb_del_bnd_,a,info) call psb_sp_setifld(nza,psb_del_bnd_,a,info)
call psb_sp_setifld(nza,psb_nnz_,a,info) call psb_sp_setifld(nza,psb_nnz_,a,info)
end if end if
@ -388,7 +415,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
case default case default
info = 2231 info = 2233
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end select end select
@ -417,11 +444,11 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
contains contains
subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,& subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,maxsz,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng) & imin,imax,jmin,jmax,nzl,info,gtl,ng)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,maxsz
integer, intent(in) :: ia(*),ja(*) 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(*)
@ -435,9 +462,14 @@ contains
info = -1 info = -1
return return
endif endif
if (nza >= nzl) then if ((nza > nzl)) then
do i=1, nz do i=1, nz
nza = nza + 1 nza = nza + 1
if (nza>maxsz) then
write(0,*) 'Out of bounds in INNER_UPD ',nza,maxsz
info = -71
return
endif
aspk(nza) = val(i) aspk(nza) = val(i)
end do end do
else else
@ -449,15 +481,23 @@ contains
ic = gtl(ic) ic = gtl(ic)
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
if (nza>maxsz) then
info = -72
return
endif
aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end if end if
end do end do
end if end if
else else
if (nza >= nzl) then if ((nza >= nzl)) then
do i=1, nz do i=1, nz
nza = nza + 1 nza = nza + 1
if (nza>maxsz) then
info = -73
return
endif
aspk(nza) = val(i) aspk(nza) = val(i)
end do end do
else else
@ -466,6 +506,10 @@ contains
ic = ja(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
if (nza>maxsz) then
info = -74
return
endif
aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end do end do
@ -473,11 +517,11 @@ contains
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,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl,ng) & imin,imax,jmin,jmax,info,gtl,ng)
implicit none implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz
integer, intent(in) :: ia(*),ja(*) 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(*)
@ -500,6 +544,10 @@ contains
ic = gtl(ic) ic = gtl(ic)
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
if (nza > maxsz) then
info = -91
return
endif
ia1(nza) = ir ia1(nza) = ir
ia2(nza) = ic ia2(nza) = ic
aspk(nza) = val(i) aspk(nza) = val(i)
@ -513,6 +561,10 @@ contains
ic = ja(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
if (nza > maxsz) then
info = -92
return
endif
ia1(nza) = ir ia1(nza) = ir
ia2(nza) = ic ia2(nza) = ic
aspk(nza) = val(i) aspk(nza) = val(i)

4
src/serial/psb_zspgtrow.f90
Unescape Escape View File

@ -60,7 +60,7 @@ subroutine psb_zspgtrow(irw,a,b,info,append,iren,lrw)
integer :: i,j,k,ip,jp,nr,idx, nz,iret,nzb, nza, lrw_, irw_, err_act integer :: i,j,k,ip,jp,nr,idx, nz,iret,nzb, nza, lrw_, irw_, err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_zspgtrow' name='psb_spgtrow'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -218,9 +218,9 @@ contains
do j=a%ia2(i),a%ia2(i+1)-1 do j=a%ia2(i),a%ia2(i+1)-1
k = k + 1 k = k + 1
b%aspk(nzb+k) = a%aspk(j)
b%ia1(nzb+k) = i b%ia1(nzb+k) = i
b%ia2(nzb+k) = a%ia1(j) b%ia2(nzb+k) = a%ia1(j)
b%aspk(nzb+k) = a%aspk(j)
!!$ write(0,*) 'csr_gtrow: in:',a%aspk(j),i,a%ia1(j) !!$ write(0,*) 'csr_gtrow: in:',a%aspk(j),i,a%ia1(j)
end do end do
enddo enddo

Write Preview
Loading…
Cancel
Save