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

Fixed problem in update for upd_srch_

Browse Source
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent f1de4b3561
commit f0dd140326
2 changed files with 405 additions and 322 deletions
Show Stats Download Patch File Download Diff File

5
Changelog
Unescape Escape View File

@ -1,6 +1,11 @@
Changelog. A lot less detailed than usual, at least for past Changelog. A lot less detailed than usual, at least for past
history. history.
2006/06/14: Defined ExtRow, probably to be renamed to GetRow.
This way we may close the mat objects.
Next we will rewrite SMMP to only make use of GetRow,
not to rely on CSR storage format.
2006/05/29: Added BLACS-like routines for data communication, 2006/05/29: Added BLACS-like routines for data communication,
broadcasts, reductions, send/receive. broadcasts, reductions, send/receive.

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

@ -174,6 +174,7 @@ contains
integer, intent(out) :: info integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*) integer, intent(in), optional :: ng,gtl(*)
logical, parameter :: debug=.false.
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
@ -201,48 +202,54 @@ contains
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir) ir = gtl(ir)
ic = gtl(ic) ic = gtl(ic)
i1 = a%ia2(ir) if ((ir > 0).and.(ir <= a%m)) then
i2 = a%ia2(ir+1) i1 = a%ia2(ir)
nc=i2-i1 i2 = a%ia2(ir+1)
nc=i2-i1
if (.true.) then if (.true.) then
call issrch(ip,ic,nc,a%ia1(i1:i2-1)) call issrch(ip,ic,nc,a%ia1(i1:i2-1))
if (ip>0) then if (ip>0) then
a%aspk(i1+ip-1) = val(i) a%aspk(i1+ip-1) = val(i)
else else
write(0,*)'Was searching ',ic,' in: ',i1,i2,' : ',a%ia1(i1:i2-1) if (debug) &
info = i & write(0,*)'Was searching ',ic,' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
return info = i
end if return
end if
else else
!!$ !!$
ip = -1 ip = -1
lb = i1 lb = i1
ub = i2-1 ub = i2-1
do do
if (lb > ub) exit if (lb > ub) exit
m = (lb+ub)/2 m = (lb+ub)/2
!!$ write(0,*) 'Debug: ',lb,m,ub !!$ write(0,*) 'Debug: ',lb,m,ub
if (ic == a%ia1(m)) then if (ic == a%ia1(m)) then
ip = m ip = m
lb = ub + 1 lb = ub + 1
else if (ic < a%ia1(m)) then else if (ic < a%ia1(m)) then
ub = m-1 ub = m-1
else
lb = m + 1
end if
enddo
if (ip>0) then
a%aspk(ip) = val(i)
else else
lb = m + 1 if (debug) write(0,*)'Was searching ',ic,&
& ' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
info = i
return
end if 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
else
if (debug) write(0,*) 'Discarding row that does not belong to us.'
end if end if
end if end if
end do end do
@ -257,22 +264,29 @@ contains
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir) ir = gtl(ir)
ic = gtl(ic) ic = gtl(ic)
i1 = a%ia2(ir) if ((ir > 0).and.(ir <= a%m)) then
i2 = a%ia2(ir+1) i1 = a%ia2(ir)
nc = i2-i1 i2 = a%ia2(ir+1)
call issrch(ip,ic,nc,a%ia1(i1:i2-1)) nc = i2-i1
if (ip>0) then !!$ write(0,*) 'ir ic ',ir,ic,i1,i2,a%m,a%k
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) 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
if (debug) write(0,*)'Was searching ',ic,&
& ' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
info = i
return
end if
else else
info = i if (debug) write(0,*) 'Discarding row that does not belong to us.'
return
end if end if
end if end if
end do end do
case default case default
info = -3 info = -3
write(0,*) 'Duplicate handling: ',dupl if (debug) write(0,*) 'Duplicate handling: ',dupl
end select end select
else else
@ -287,49 +301,57 @@ contains
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
i1 = a%ia2(ir)
i2 = a%ia2(ir+1)
nc=i2-i1
if ((ir > 0).and.(ir <= a%m)) then
if (.true.) then i1 = a%ia2(ir)
call issrch(ip,ic,nc,a%ia1(i1:i2-1)) i2 = a%ia2(ir+1)
if (ip>0) then nc=i2-i1
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
!!$ if (.true.) then
ip = -1 call issrch(ip,ic,nc,a%ia1(i1:i2-1))
lb = i1 if (ip>0) then
ub = i2-1 a%aspk(i1+ip-1) = val(i)
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 else
lb = m + 1 if (debug) write(0,*)'Was searching ',ic,&
& ' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
info = i
return
end if end if
enddo
if (ip>0) then
a%aspk(ip) = val(i)
else else
write(0,*)'Was searching ',ic,' in: ',i1,i2,' : ',a%ia1(i1:i2-1) !!$
info = i ip = -1
return lb = i1
end if 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
if (debug) write(0,*)'Was searching ',ic,&
& ' in: ',i1,i2,' : ',a%ia1(i1:i2-1)
info = i
return
end if
end if
else
if (debug) write(0,*) 'Discarding row that does not belong to us.'
end if end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
@ -339,21 +361,25 @@ contains
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
i1 = a%ia2(ir) if ((ir > 0).and.(ir <= a%m)) then
i2 = a%ia2(ir+1) i1 = a%ia2(ir)
nc = i2-i1 i2 = a%ia2(ir+1)
call issrch(ip,ic,nc,a%ia1(i1:i2-1)) nc = i2-i1
if (ip>0) then call issrch(ip,ic,nc,a%ia1(i1:i2-1))
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) if (ip>0) then
a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i)
else
info = i
return
end if
else else
info = i if (debug) write(0,*) 'Discarding row that does not belong to us.'
return
end if end if
end do end do
case default case default
info = -3 info = -3
write(0,*) 'Duplicate handling: ',dupl if (debug) write(0,*) 'Duplicate handling: ',dupl
end select end select
end if end if
@ -372,6 +398,7 @@ contains
integer, intent(in), optional :: ng,gtl(*) 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
logical, parameter :: debug=.false.
info = 0 info = 0
@ -397,12 +424,97 @@ contains
case(psb_dupl_ovwrt_,psb_dupl_err_) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ! Overwrite.
! Cannot test for error, should have been caught earlier. ! 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)
if ((ir > 0).and.(ir <= a%m)) then
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
else
if (debug) write(0,*) 'Discarding row does not belong'
endif
end if
end do
case(psb_dupl_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 if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir) ir = gtl(ir)
ic = gtl(ic) ic = gtl(ic)
if ((ir > 0).and.(ir <= a%m)) then
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
else
if (debug) write(0,*) 'Discarding row does not belong'
end if
end if
end do
case default
info = -3
if (debug) 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 > 0).and.(ir <= a%m)) then
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
@ -428,14 +540,14 @@ contains
end if 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 if ((ir > 0).and.(ir <= a%m)) 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
@ -464,76 +576,7 @@ contains
case default case default
info = -3 info = -3
write(0,*) 'Duplicate handling: ',dupl if (debug) 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
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 do
case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
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 do
case default
info = -3
write(0,*) 'Duplicate handling: ',dupl
end select end select
end if end if
@ -556,6 +599,7 @@ contains
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
logical, parameter :: debug=.false.
info = 0 info = 0
dupl = psb_sp_getifld(psb_dupl_,a,info) dupl = psb_sp_getifld(psb_dupl_,a,info)
@ -580,6 +624,102 @@ contains
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir) ir = gtl(ir)
ic = gtl(ic) ic = gtl(ic)
if ((ir > 0).and.(ir <= a%m)) then
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
else
if (debug) write(0,*) 'Discarding row does not belong'
endif
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)
if ((ir > 0).and.(ir <= a%m)) then
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
else
if (debug) write(0,*) 'Discarding row does not belong'
endif
end if
end do
case default
info = -3
if (debug) 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)
if ((ir > 0).and.(ir <= a%m)) then
i1 = a%ia2(ir) i1 = a%ia2(ir)
i2 = a%ia2(ir+1) i2 = a%ia2(ir+1)
nc=i2-i1 nc=i2-i1
@ -623,7 +763,9 @@ contains
end if end if
end if end if
end if else
if (debug) write(0,*) 'Discarding row does not belong'
endif
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
@ -633,9 +775,7 @@ contains
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 if ((ir > 0).and.(ir <= a%m)) 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
@ -646,93 +786,14 @@ contains
info = i info = i
return return
end if 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)
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 do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
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 else
info = i if (debug) write(0,*) 'Discarding row does not belong'
return endif
end if
end do end do
case default case default
info = -3 info = -3
write(0,*) 'Duplicate handling: ',dupl if (debug) write(0,*) 'Duplicate handling: ',dupl
end select end select
end if end if
@ -751,6 +812,7 @@ contains
integer, intent(in), optional :: ng,gtl(*) 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
logical, parameter :: debug=.false.
info = 0 info = 0
@ -782,6 +844,88 @@ contains
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir) ir = gtl(ir)
ic = gtl(ic) ic = gtl(ic)
if ((ir > 0).and.(ir <= a%m)) then
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
else
if (debug) write(0,*) 'Discarding row does not belong'
endif
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 > 0).and.(ir <= a%m)) then
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
else
if (debug) write(0,*) 'Discarding row does not belong'
endif
end if
end do
case default
info = -3
if (debug) 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 > 0).and.(ir <= a%m)) then
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
@ -805,16 +949,17 @@ contains
info = i info = i
return return
end if end if
end if else
if (debug) write(0,*) 'Discarding row does not belong'
endif
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 if ((ir > 0).and.(ir <= a%m)) 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
@ -838,81 +983,14 @@ contains
info = i info = i
return return
end if 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
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 else
info = i if (debug) write(0,*) 'Discarding row does not belong'
return endif
end if
end do
case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
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 do end do
case default case default
info = -3 info = -3
write(0,*) 'Duplicate handling: ',dupl if (debug) write(0,*) 'Duplicate handling: ',dupl
end select end select
end if end if

Write Preview
Loading…
Cancel
Save