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

Changed handling of duplicates and storage format. Changed interface

Browse Source 
to both geins and spasb. New and better strategies.
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent 77106751a4
commit 4b2f930cf6
32 changed files with 1878 additions and 1447 deletions
Show Stats Download Patch File Download Diff File

25
src/modules/psb_const.fh
Unescape Escape View File

@ -80,28 +80,31 @@
! !
! Queries into spmat%info ! Queries into spmat%info
! !
integer, parameter :: psb_root_=0
integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2 integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2
integer, parameter :: psb_nzsizereq_=3 integer, parameter :: psb_nzsizereq_=3
! !
! Entries and values for spmat%info ! Entries and values for spmat%info
! !
integer, parameter :: psb_nnz_=1, psb_dupl_=5 integer, parameter :: psb_nnz_=1
integer, parameter :: psb_del_bnd_=6, psb_srtd_=7 integer, parameter :: psb_del_bnd_=7, psb_srtd_=8
integer, parameter :: psb_state_=8, psb_upd_=9 integer, parameter :: psb_state_=9
integer, parameter :: psb_upd_pnt_=10, psb_ifasize_=10 integer, parameter :: psb_upd_pnt_=10
integer, parameter :: psb_dupl_=11, psb_upd_=12
integer, parameter :: psb_ifasize_=16
integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1
integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4
integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0 integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0
integer, parameter :: psb_iflag_=2, psb_ichk_=3 integer, parameter :: psb_iflag_=2, psb_ichk_=3
integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6 integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6
integer, parameter :: psb_dupl_err_ =1 integer, parameter :: psb_dupl_ovwrt_ = 0
integer, parameter :: psb_dupl_ovwrt_=2 integer, parameter :: psb_dupl_add_ = 1
integer, parameter :: psb_dupl_add_ =3 integer, parameter :: psb_dupl_err_ = 2
integer, parameter :: psb_perm_update_=98765 integer, parameter :: psb_dupl_def_ = psb_dupl_ovwrt_
integer, parameter :: psb_srch_update_=98764 integer, parameter :: psb_upd_dflt_ = 0
integer, parameter :: psb_isrtdcoo_ =98761 integer, parameter :: psb_upd_perm_ = 98765
integer, parameter :: psb_upd_srch_ = 98764
integer, parameter :: psb_isrtdcoo_ = 98761
integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4 integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4
integer, parameter :: psb_dbleint_=2 integer, parameter :: psb_dbleint_=2
! !

55
src/modules/psb_realloc_mod.f90
Unescape Escape View File

@ -68,36 +68,37 @@ Contains
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax) dim=size(rrax)
If (dim /= len) Then If (dim /= len) Then
Allocate(tmp(len),stat=info) Allocate(tmp(len),stat=info)
if (info /= 0) then if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
if (.true.) then
do i=1, min(len,dim)
tmp(i)=rrax(i)
end do
else
tmp(1:min(len,dim))=rrax(1:min(len,dim))
end if
deallocate(rrax,stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
rrax=>tmp
end if
else
allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
if (.true.) then
do i=1, min(len,dim)
tmp(i)=rrax(i)
end do
else
tmp(1:min(len,dim))=rrax(1:min(len,dim))
end if
deallocate(rrax,stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
rrax=>tmp
end if
else
dim = 0
allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(dim+1:len) = pad rrax(dim+1:len) = pad

133
src/modules/psb_spmat_type.f90
Unescape Escape View File

@ -47,7 +47,7 @@ module psb_spmat_type
! describe some chacteristics of sparse matrix ! describe some chacteristics of sparse matrix
character(len=11) :: descra character(len=11) :: descra
! Contains some additional informations on sparse matrix ! Contains some additional informations on sparse matrix
integer :: infoa(10) integer :: infoa(psb_ifasize_)
! Contains sparse matrix coefficients ! Contains sparse matrix coefficients
real(kind(1.d0)), pointer :: aspk(:)=>null() real(kind(1.d0)), pointer :: aspk(:)=>null()
! Contains indeces that describes sparse matrix structure ! Contains indeces that describes sparse matrix structure
@ -63,7 +63,7 @@ module psb_spmat_type
! describe some chacteristics of sparse matrix ! describe some chacteristics of sparse matrix
character(len=11) :: descra character(len=11) :: descra
! Contains some additional informations on sparse matrix ! Contains some additional informations on sparse matrix
integer :: infoa(10) integer :: infoa(psb_ifasize_)
! Contains sparse matrix coefficients ! Contains sparse matrix coefficients
complex(kind(1.d0)), pointer :: aspk(:)=>null() complex(kind(1.d0)), pointer :: aspk(:)=>null()
! Contains indeces that describes sparse matrix structure ! Contains indeces that describes sparse matrix structure
@ -80,6 +80,14 @@ module psb_spmat_type
module procedure psb_dspclone, psb_zspclone module procedure psb_dspclone, psb_zspclone
end interface end interface
interface psb_sp_setifld
module procedure psb_dsp_setifld, psb_zsp_setifld
end interface
interface psb_sp_getifld
module procedure psb_dsp_getifld, psb_zsp_getifld
end interface
interface psb_sp_transfer interface psb_sp_transfer
module procedure psb_dsp_transfer, psb_zsp_transfer module procedure psb_dsp_transfer, psb_zsp_transfer
end interface end interface
@ -212,7 +220,7 @@ contains
a%m=max(0,m) a%m=max(0,m)
a%k=max(0,k) a%k=max(0,k)
call psb_sp_reall(a,nnz,info) call psb_sp_reall(a,nnz,info)
if (debug) write(0,*) 'Check in ALLOCATE ',info,associated(a%pl),associated(a%pr)
a%pl(1)=0 a%pl(1)=0
a%pr(1)=0 a%pr(1)=0
! set infoa fields ! set infoa fields
@ -296,6 +304,8 @@ contains
call psb_realloc(max(1,a%m),a%pl,info) call psb_realloc(max(1,a%m),a%pl,info)
if (info /= 0) return if (info /= 0) return
call psb_realloc(max(1,a%k),a%pr,info) call psb_realloc(max(1,a%k),a%pr,info)
if (debug) write(0,*) associated(a%ia1),associated(a%ia2),&
& associated(a%aspk),associated(a%pl),associated(a%pr),info
if (info /= 0) return if (info /= 0) return
Return Return
@ -420,6 +430,63 @@ contains
End Subroutine psb_dsp_transfer End Subroutine psb_dsp_transfer
Subroutine psb_dsp_setifld(val,field,a,info)
implicit none
!....Parameters...
Type(psb_dspmat_type), intent(inout) :: A
Integer, intent(in) :: field,val
Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
info = 0
!!$ call psb_realloc(psb_ifasize_,a%infoa,info)
if (info == 0) &
& call psb_setifield(val,field,a%infoa,psb_ifasize_,info)
Return
end subroutine psb_dsp_setifld
function psb_dsp_getifld(field,a,info)
implicit none
!....Parameters...
Type(psb_dspmat_type), intent(in) :: A
Integer, intent(in) :: field
Integer :: psb_dsp_getifld
Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
integer :: val
info = 0
val = -1
if ((field < 1).or.(field > psb_ifasize_)) then
info = -1
psb_dsp_getifld = val
return
endif
!!$ if (.not.associated(a%infoa)) then
!!$ info = -2
!!$ return
!!$ endif
call psb_getifield(val,field,a%infoa,psb_ifasize_,info)
psb_dsp_getifld = val
Return
end function psb_dsp_getifld
subroutine psb_dsp_free(a,info) subroutine psb_dsp_free(a,info)
implicit none implicit none
!....Parameters... !....Parameters...
@ -765,6 +832,66 @@ contains
End Subroutine psb_zsp_transfer End Subroutine psb_zsp_transfer
Subroutine psb_zsp_setifld(val,field,a,info)
implicit none
!....Parameters...
Type(psb_zspmat_type), intent(inout) :: A
Integer, intent(in) :: field,val
Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
info = 0
!!$ call psb_realloc(psb_ifasize_,a%infoa,info)
if (info == 0) &
& call psb_setifield(val,field,a%infoa,psb_ifasize_,info)
Return
end subroutine psb_zsp_setifld
function psb_zsp_getifld(field,a,info)
implicit none
!....Parameters...
Type(psb_zspmat_type), intent(in) :: A
Integer, intent(in) :: field
Integer :: psb_zsp_getifld
Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
integer :: val
info = 0
val = -1
if ((field < 1).or.(field > psb_ifasize_)) then
info = -1
psb_zsp_getifld = val
return
endif
!!$ if (.not.associated(a%infoa)) then
!!$ info = -2
!!$ return
!!$ endif
call psb_getifield(val,field,a%infoa,psb_ifasize_,info)
psb_zsp_getifld = val
Return
end function psb_zsp_getifld
subroutine psb_zsp_free(a,info) subroutine psb_zsp_free(a,info)
implicit none implicit none

39
src/modules/psb_tools_mod.f90
Unescape Escape View File

@ -293,7 +293,7 @@ Module psb_tools_mod
interface psb_geins interface psb_geins
! 2-D double precision version ! 2-D double precision version
subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,& subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck) & iblck, jblck,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m,n integer, intent(in) :: m,n
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -302,10 +302,11 @@ Module psb_tools_mod
real(kind(1.d0)), intent(in) :: blck(:,:) real(kind(1.d0)), intent(in) :: blck(:,:)
integer,intent(out) :: info integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
end subroutine psb_dins end subroutine psb_dins
! 2-D double precision square version ! 2-D double precision square version
subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,& subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck) & iblck,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -314,10 +315,11 @@ Module psb_tools_mod
real(kind(1.d0)), intent(in) :: blck(:) real(kind(1.d0)), intent(in) :: blck(:)
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
end subroutine psb_dinsvm end subroutine psb_dinsvm
! 1-D double precision version ! 1-D double precision version
subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,& subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag) & iblck,insflag,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -327,10 +329,11 @@ Module psb_tools_mod
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
end subroutine psb_dinsvv end subroutine psb_dinsvv
! 2-D integer version ! 2-D integer version
subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,& subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck) & iblck, jblck,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m,n integer, intent(in) :: m,n
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -339,10 +342,11 @@ Module psb_tools_mod
integer, intent(in) :: blck(:,:) integer, intent(in) :: blck(:,:)
integer,intent(out) :: info integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
end subroutine psb_iins end subroutine psb_iins
! 2-D integer square version ! 2-D integer square version
subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a,info,& subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck) & iblck,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -351,10 +355,11 @@ Module psb_tools_mod
integer, intent(in) :: blck(:) integer, intent(in) :: blck(:)
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
end subroutine psb_iinsvm end subroutine psb_iinsvm
! 1-D integer version ! 1-D integer version
subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,& subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag) & iblck,insflag,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -364,10 +369,11 @@ Module psb_tools_mod
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
end subroutine psb_iinsvv end subroutine psb_iinsvv
! 2-D double precision version ! 2-D double precision version
subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,& subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck) & iblck, jblck,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m,n integer, intent(in) :: m,n
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -376,10 +382,11 @@ Module psb_tools_mod
complex(kind(1.d0)), intent(in) :: blck(:,:) complex(kind(1.d0)), intent(in) :: blck(:,:)
integer,intent(out) :: info integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
end subroutine psb_zins end subroutine psb_zins
! 2-D double precision square version ! 2-D double precision square version
subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,& subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck) & iblck,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -388,10 +395,11 @@ Module psb_tools_mod
complex(kind(1.d0)), intent(in) :: blck(:) complex(kind(1.d0)), intent(in) :: blck(:)
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
end subroutine psb_zinsvm end subroutine psb_zinsvm
! 1-D double precision version ! 1-D double precision version
subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,& subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag) & iblck,insflag,dupl)
use psb_descriptor_type use psb_descriptor_type
integer, intent(in) :: m integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -401,6 +409,7 @@ Module psb_tools_mod
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
end subroutine psb_zinsvv end subroutine psb_zinsvv
end interface end interface
@ -523,23 +532,23 @@ Module psb_tools_mod
end interface end interface
interface psb_spasb interface psb_spasb
subroutine psb_dspasb(a,desc_a, info, afmt, up, dup) subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
use psb_descriptor_type use psb_descriptor_type
use psb_spmat_type use psb_spmat_type
type(psb_dspmat_type), intent (inout) :: a type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
integer,optional, intent(in) :: dup integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5, up character, optional, intent(in) :: afmt*5
end subroutine psb_dspasb end subroutine psb_dspasb
subroutine psb_zspasb(a,desc_a, info, afmt, up, dup) subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
use psb_descriptor_type use psb_descriptor_type
use psb_spmat_type use psb_spmat_type
type(psb_zspmat_type), intent (inout) :: a type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
integer,optional, intent(in) :: dup integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5, up character, optional, intent(in) :: afmt*5
end subroutine psb_zspasb end subroutine psb_zspasb
end interface end interface

3
src/prec/psb_dbldaggrmat.f90
Unescape Escape View File

@ -165,7 +165,8 @@ contains
goto 9999 goto 9999
end if end if
b%infoa(psb_upd_) = 6 call psb_sp_setifld(psb_dupl_ovwrt_,psb_dupl_,b,info)
call psb_sp_setifld(psb_upd_dflt_,psb_upd_,b,info)
b%fida = 'COO' b%fida = 'COO'
b%m=a%m b%m=a%m
b%k=a%k b%k=a%k

3
src/prec/psb_zbldaggrmat.f90
Unescape Escape View File

@ -165,7 +165,8 @@ contains
goto 9999 goto 9999
end if end if
b%infoa(psb_upd_) = 6 call psb_sp_setifld(psb_dupl_ovwrt_,psb_dupl_,b,info)
call psb_sp_setifld(psb_upd_dflt_,psb_upd_,b,info)
b%fida = 'COO' b%fida = 'COO'
b%m=a%m b%m=a%m
b%k=a%k b%k=a%k

256
src/psblas/psb_dspmm.f90
Unescape Escape View File

@ -457,14 +457,14 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol /= 1) then else if (npcol /= 1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
ia = 1 ia = 1
@ -477,25 +477,25 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
ib = 1 ib = 1
if (present(doswap)) then if (present(doswap)) then
idoswap = doswap idoswap = doswap
else else
idoswap = 1 idoswap = 1
endif endif
if (present(trans)) then if (present(trans)) then
if ( (toupper(trans).eq.'N').or.(toupper(trans).eq.'T')) then if ( (toupper(trans).eq.'N').or.(toupper(trans).eq.'T')) then
itrans = toupper(trans) itrans = toupper(trans)
else if (toupper(trans).eq.'C') then else if (toupper(trans).eq.'C') then
info = 3020 info = 3020
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else else
info = 70 info = 70
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
else else
itrans = 'N' itrans = 'N'
endif endif
m = desc_a%matrix_data(psb_m_) m = desc_a%matrix_data(psb_m_)
@ -509,143 +509,143 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
liwork= 2*ncol liwork= 2*ncol
if (a%pr(1) /= 0) liwork = liwork + n * ik if (a%pr(1) /= 0) liwork = liwork + n * ik
if (a%pl(1) /= 0) liwork = liwork + m * ik if (a%pl(1) /= 0) liwork = liwork + m * ik
! write(0,*)'---->>>',work(1) ! write(0,*)'---->>>',work(1)
if (present(work)) then if (present(work)) then
if(size(work).ge.liwork) then if(size(work).ge.liwork) then
iwork => work iwork => work
liwork=size(work) liwork=size(work)
else else
call psb_realloc(liwork,iwork,info) call psb_realloc(liwork,iwork,info)
if(info.ne.0) then if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
end if
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if end if
! checking for matrix correctness ! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja) call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkmat' ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (itrans.eq.'N') then if (itrans.eq.'N') then
! Matrix is not transposed ! Matrix is not transposed
if((ja.ne.ix).or.(ia.ne.iy)) then if((ja.ne.ix).or.(ia.ne.iy)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3030 info = 3030
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! checking for vectors correctness ! checking for vectors correctness
call psb_chkvect(n,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(n,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(m,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy) call psb_chkvect(m,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkvect' ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if((iix.ne.1).or.(iiy.ne.1)) then if((iix.ne.1).or.(iiy.ne.1)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3040 info = 3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (idoswap == 0) then if (idoswap == 0) then
x(nrow+1:ncol)=dzero x(nrow+1:ncol)=dzero
else else
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& dzero,x,desc_a,iwork,info,data=psb_comm_halo_) & dzero,x,desc_a,iwork,info,data=psb_comm_halo_)
end if end if
! local Matrix-vector product ! local Matrix-vector product
call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info) call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info)
if(info.ne.0) then if(info.ne.0) then
info = 4011 info = 4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
else else
! Matrix is transposed ! Matrix is transposed
if((ja.ne.iy).or.(ia.ne.ix)) then if((ja.ne.iy).or.(ia.ne.ix)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3030 info = 3030
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if(desc_a%ovrlap_elem(1).ne.-1) then if(desc_a%ovrlap_elem(1).ne.-1) then
info = 3070 info = 3070
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! checking for vectors correctness ! checking for vectors correctness
call psb_chkvect(m,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(n,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy) call psb_chkvect(n,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkvect' ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if((iix.ne.1).or.(iiy.ne.1)) then if((iix.ne.1).or.(iiy.ne.1)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3040 info = 3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
xp => x(iix:lldx) xp => x(iix:lldx)
yp => y(iiy:lldy) yp => y(iiy:lldy)
yp(nrow+1:ncol)=dzero yp(nrow+1:ncol)=dzero
! local Matrix-vector product ! local Matrix-vector product
call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans) call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans)
if(info.ne.0) then if(info.ne.0) then
info = 4010 info = 4010
ch_err='dcsmm' ch_err='dcsmm'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if(idoswap /= 0)& if(idoswap /= 0)&
& call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& done,yp,desc_a,iwork,info) & done,yp,desc_a,iwork,info)
if(info.ne.0) then if(info.ne.0) then
info = 4010 info = 4010
ch_err='PSI_dSwapTran' ch_err='PSI_dSwapTran'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
end if end if
if(.not.present(work)) then if(.not.present(work)) then
deallocate(iwork) deallocate(iwork)
end if end if
nullify(iwork) nullify(iwork)
@ -656,8 +656,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return
end subroutine psb_dspmv end subroutine psb_dspmv

189
src/psblas/psb_dspsm.f90
Unescape Escape View File

@ -81,6 +81,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
use psi_mod use psi_mod
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_string_mod
implicit none implicit none
real(kind(1.D0)), intent(in) :: alpha, beta real(kind(1.D0)), intent(in) :: alpha, beta
@ -159,16 +160,16 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
endif endif
if (present(unitd)) then if (present(unitd)) then
lunitd = unitd lunitd = toupper(unitd)
else else
lunitd = 'U' lunitd = 'U'
endif endif
if (present(trans)) then if (present(trans)) then
if ((trans.eq.'N').or.(trans.eq.'T')& itrans = toupper(trans)
& .or.(trans.eq.'n').or.(trans.eq.'t')) then if((itrans.eq.'N').or.(itrans.eq.'T')) then
itrans = trans ! Ok
else if ((trans.eq.'C').or.(trans.eq.'c')) then else if (itrans.eq.'C') then
info = 3020 info = 3020
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -388,6 +389,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
use psi_mod use psi_mod
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_string_mod
real(kind(1.D0)), intent(in) :: alpha, beta real(kind(1.D0)), intent(in) :: alpha, beta
real(kind(1.d0)), intent(in), target :: x(:) real(kind(1.d0)), intent(in), target :: x(:)
@ -422,14 +424,14 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol /= 1) then else if (npcol /= 1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
! just this case right now ! just this case right now
@ -448,25 +450,26 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
endif endif
if (present(unitd)) then if (present(unitd)) then
lunitd = unitd lunitd = toupper(unitd)
else else
lunitd = 'U' lunitd = 'U'
endif endif
if (present(trans)) then if (present(trans)) then
if((trans.eq.'N').or.(trans.eq.'T')) then itrans = toupper(trans)
itrans = trans if((itrans.eq.'N').or.(itrans.eq.'T')) then
else if (trans.eq.'C') then ! Ok
info = 3020 else if (itrans.eq.'C') then
call psb_errpush(info,name) info = 3020
goto 9999 call psb_errpush(info,name)
else goto 9999
info = 70 else
call psb_errpush(info,name) info = 70
goto 9999 call psb_errpush(info,name)
end if goto 9999
end if
else else
itrans = 'N' itrans = 'N'
endif endif
m = desc_a%matrix_data(psb_m_) m = desc_a%matrix_data(psb_m_)
@ -476,9 +479,9 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
lldy = size(y) lldy = size(y)
if((lldx.lt.ncol).or.(lldy.lt.ncol)) then if((lldx.lt.ncol).or.(lldy.lt.ncol)) then
info=3010 info=3010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! check for presence/size of a work area ! check for presence/size of a work area
@ -486,34 +489,34 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
if (a%pr(1) /= 0) llwork = liwork + m * ik if (a%pr(1) /= 0) llwork = liwork + m * ik
if (a%pl(1) /= 0) llwork = llwork + m * ik if (a%pl(1) /= 0) llwork = llwork + m * ik
if (present(work)) then if (present(work)) then
if(size(work).lt.liwork) then if(size(work).lt.liwork) then
call psb_realloc(liwork,work,info) call psb_realloc(liwork,work,info)
if(info.ne.0) then if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
iwork => work
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
end if
iwork => work
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if end if
iwork(1)=0.d0 iwork(1)=0.d0
if(present(d)) then if (present(d)) then
lld = size(d) lld = size(d)
id => d id => d
else else
lld=1 lld=1
allocate(id(1)) allocate(id(1))
id=1.d0 id=1.d0
end if end if
! checking for matrix correctness ! checking for matrix correctness
@ -522,25 +525,25 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
call psb_chkvect(m,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(m,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy) call psb_chkvect(m,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkvect/mat' ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if(ja.ne.ix) then if(ja.ne.ix) then
! this case is not yet implemented ! this case is not yet implemented
info = 3030 info = 3030
end if end if
if((iix.ne.1).or.(iiy.ne.1)) then if((iix.ne.1).or.(iiy.ne.1)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3040 info = 3040
end if end if
if(info.ne.0) then if(info.ne.0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! Perform local triangular system solve ! Perform local triangular system solve
@ -549,43 +552,43 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans)
if(info.ne.0) then if(info.ne.0) then
info = 4010 info = 4010
ch_err='dcssm' ch_err='dcssm'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
! update overlap elements ! update overlap elements
if(lchoice.gt.0) then if(lchoice.gt.0) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& done,yp,desc_a,iwork,info) & done,yp,desc_a,iwork,info)
i=0 i=0
! switch on update type ! switch on update type
select case (lchoice) select case (lchoice)
case(psb_square_root_) case(psb_square_root_)
do while(desc_a%ovrlap_elem(i).ne.-ione) do while(desc_a%ovrlap_elem(i).ne.-ione)
y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =&
& y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& & y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/&
& sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))) & sqrt(real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)))
i = i+2 i = i+2
end do end do
case(psb_avg_) case(psb_avg_)
do while(desc_a%ovrlap_elem(i).ne.-ione) do while(desc_a%ovrlap_elem(i).ne.-ione)
y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =& y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_)) =&
& y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/& & y(desc_a%ovrlap_elem(i+psb_ovrlp_elem_))/&
& real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_)) & real(desc_a%ovrlap_elem(i+psb_n_dom_ovr_))
i = i+2 i = i+2
end do end do
case(psb_sum_) case(psb_sum_)
! do nothing ! do nothing
case default case default
! wrong value for choice argument ! wrong value for choice argument
info = 70 info = 70
int_err=(/10,lchoice,0,0,0/) int_err=(/10,lchoice,0,0,0/)
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end select end select
end if end if
if(.not.present(work)) deallocate(iwork) if(.not.present(work)) deallocate(iwork)
@ -598,8 +601,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return
end subroutine psb_dspsv end subroutine psb_dspsv

3
src/serial/Makefile
Unescape Escape View File

@ -11,7 +11,8 @@ FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \
psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zcsdp.o\ psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zcsdp.o\
psb_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.o \ psb_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.o \
psb_zcoins.o psb_zcsprt.o psb_zneigh.o psb_ztransp.o \ psb_zcoins.o psb_zcsprt.o psb_zneigh.o psb_ztransp.o \
psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspinfo.o psb_zspscal.o psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspinfo.o psb_zspscal.o\
psb_getifield.o psb_setifield.o
INCDIRS = -I ../../lib -I . INCDIRS = -I ../../lib -I .

2
src/serial/aux/Makefile
Unescape Escape View File

@ -4,7 +4,7 @@ include ../../../Make.inc
# #
FOBJS = isr.o isrx.o \ FOBJS = isr.o isrx.o \
mrgsrt.o isaperm.o ibsrch.o mrgsrt.o isaperm.o ibsrch.o imsr.o imsrx.o
OBJS=$(FOBJS) OBJS=$(FOBJS)

3
src/serial/imsr.f90 → src/serial/aux/imsr.f90
Unescape Escape View File

@ -30,7 +30,8 @@
!!$ !!$
! File: imsr.f90 ! File: imsr.f90
! Subroutine: ! Subroutine:
! Parameters:subroutine imsr(n,x) ! Parameters:
subroutine imsr(n,x)
integer :: n integer :: n
integer :: x(n) integer :: x(n)

3
src/serial/imsrx.f90 → src/serial/aux/imsrx.f90
Unescape Escape View File

@ -30,7 +30,8 @@
!!$ !!$
! File: imsrx.f90 ! File: imsrx.f90
! Subroutine: ! Subroutine:
! Parameters:subroutine imsrx(n,x,indx) ! Parameters:
subroutine imsrx(n,x,indx)
integer :: n integer :: n
integer :: x(n) integer :: x(n)
integer :: indx(n) integer :: indx(n)

21
src/serial/dp/dcoco.f
Unescape Escape View File

@ -71,13 +71,14 @@ c
ierror = 0 ierror = 0
call fcpsb_erractionsave(err_act) call fcpsb_erractionsave(err_act)
check_flag=ibits(info(psb_upd_),1,2) call psb_getifield(check_flag,psb_dupl_,info,psb_ifasize_,ierror)
if (trans.eq.'N') then if (trans.eq.'N') then
scale = (unitd.eq.'L') ! meaningless scale = (unitd.eq.'L') ! meaningless
p1(1) = 0 p1(1) = 0
p2(1) = 0 p2(1) = 0
nnz = info(psb_nnz_) call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror)
if (debug) then if (debug) then
write(*,*) 'on entry to dcoco: nnz laux ', write(*,*) 'on entry to dcoco: nnz laux ',
+ nnz,laux,larn,lia1n,lia2n + nnz,laux,larn,lia1n,lia2n
@ -171,16 +172,16 @@ c ... insert remaining element ...
do elem_in = 2, nnz do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and. if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (ia2n(elem_in).eq.ia2n(elem_out))) then + (ia2n(elem_in).eq.ia2n(elem_out))) then
if (check_flag.eq.1) then if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ... c ... error, there are duplicated elements ...
ierror = 130 ierror = 130
call fcpsb_errpush(ierror,name,int_val) call fcpsb_errpush(ierror,name,int_val)
goto 9999 goto 9999
else if (check_flag.eq.2) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the first duplicated element ... c ... insert only the first duplicated element ...
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
else if (check_flag.eq.3) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... add the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in) arn(elem_out) = arn(elem_out) + arn(elem_in)
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
end if end if
@ -219,15 +220,15 @@ c ... insert remaining element ...
do elem_in = 2, nnz do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and. if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (ia2n(elem_in).eq.ia2n(elem_out))) then + (ia2n(elem_in).eq.ia2n(elem_out))) then
if (check_flag.eq.1) then if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ... c ... error, there are duplicated elements ...
ierror = 130 ierror = 130
call fcpsb_errpush(ierror,name,int_val) call fcpsb_errpush(ierror,name,int_val)
goto 9999 goto 9999
else if (check_flag.eq.2) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the first duplicated element ... c ... insert only the first duplicated element ...
else if (check_flag.eq.3) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... add the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in) arn(elem_out) = arn(elem_out) + arn(elem_in)
end if end if
else else

16
src/serial/dp/dcocr.f
Unescape Escape View File

@ -73,8 +73,8 @@ C
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
CHECK_FLAG=IBITS(INFO(PSB_UPD_),1,2) call psb_getifield(check_flag,psb_dupl_,info,psb_ifasize_,ierror)
c$$$ write(0,*) 'DCOCR FLAG ',info(psb_upd_),check_flag
IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN
SCALE = (UNITD.EQ.'L') ! meaningless SCALE = (UNITD.EQ.'L') ! meaningless
@ -221,16 +221,16 @@ C ... Insert other element of row ...
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM_CSR = ELEM_CSR+1 ELEM_CSR = ELEM_CSR+1
ELSE ELSE
IF (CHECK_FLAG.EQ.1) THEN IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ... C ... Error, there are duplicated elements ...
IERROR = 130 IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999 GOTO 9999
ELSE IF (CHECK_FLAG.EQ.2) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ... C ... Insert only the last duplicated element ...
ARN(ELEM_CSR-1) = AR(ELEM) ARN(ELEM_CSR-1) = AR(ELEM)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
ELSE IF (CHECK_FLAG.EQ.3) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ... C ... Sum the duplicated element ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
@ -296,17 +296,17 @@ C ... Insert other element of row ...
ARN(ELEM_CSR) = AR(ELEM) ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1 ELEM_CSR = ELEM_CSR+1
ELSE ELSE
IF (CHECK_FLAG.EQ.1) THEN IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ... C ... Error, there are duplicated elements ...
IERROR = 130 IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999 GOTO 9999
ELSE IF (CHECK_FLAG.EQ.2) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ... C ... Insert only the last duplicated element ...
ARN(ELEM_CSR-1) = AR(ELEM) ARN(ELEM_CSR-1) = AR(ELEM)
if (debug) write(0,*) 'Duplicated overwrite', if (debug) write(0,*) 'Duplicated overwrite',
+ elem_csr-1,elem + elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.3) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ... C ... Sum the duplicated element ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
if (debug) write(0,*) 'Duplicated add', if (debug) write(0,*) 'Duplicated add',

4
src/serial/dp/dgindex.f
Unescape Escape View File

@ -59,7 +59,9 @@ c .. Local Arrays ..
POINT_AR = 1 POINT_AR = 1
POINT_JA = 0 POINT_JA = 0
CHECK_FLAG=IBITS(INFON(PSB_UPD_),1,2)
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60 IERROR = 60

14
src/serial/dp/zcoco.f
Unescape Escape View File

@ -71,7 +71,7 @@ c
ierror = 0 ierror = 0
call fcpsb_erractionsave(err_act) call fcpsb_erractionsave(err_act)
check_flag=ibits(info(psb_upd_),1,2) call psb_getifield(check_flag,psb_dupl_,info,psb_ifasize_,ierror)
if (trans.eq.'N') then if (trans.eq.'N') then
scale = (unitd.eq.'L') ! meaningless scale = (unitd.eq.'L') ! meaningless
p1(1) = 0 p1(1) = 0
@ -172,15 +172,15 @@ c ... insert remaining element ...
do elem_in = 2, nnz do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and. if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (ia2n(elem_in).eq.ia2n(elem_out))) then + (ia2n(elem_in).eq.ia2n(elem_out))) then
if (check_flag.eq.1) then if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ... c ... error, there are duplicated elements ...
ierror = 130 ierror = 130
call fcpsb_errpush(ierror,name,int_val) call fcpsb_errpush(ierror,name,int_val)
goto 9999 goto 9999
else if (check_flag.eq.2) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the first duplicated element ... c ... insert only the first duplicated element ...
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
else if (check_flag.eq.3) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in) arn(elem_out) = arn(elem_out) + arn(elem_in)
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
@ -220,14 +220,14 @@ c ... insert remaining element ...
do elem_in = 2, nnz do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and. if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (ia2n(elem_in).eq.ia2n(elem_out))) then + (ia2n(elem_in).eq.ia2n(elem_out))) then
if (check_flag.eq.1) then if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ... c ... error, there are duplicated elements ...
ierror = 130 ierror = 130
call fcpsb_errpush(ierror,name,int_val) call fcpsb_errpush(ierror,name,int_val)
goto 9999 goto 9999
else if (check_flag.eq.2) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the first duplicated element ... c ... insert only the first duplicated element ...
else if (check_flag.eq.3) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in) arn(elem_out) = arn(elem_out) + arn(elem_in)
end if end if

28
src/serial/dp/zcocr.f
Unescape Escape View File

@ -73,8 +73,8 @@ C
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
CHECK_FLAG=IBITS(INFO(PSB_UPD_),1,2) call psb_getifield(check_flag,psb_dupl_,info,psb_ifasize_,ierror)
c$$$ write(0,*) 'ZCOCR FLAG ',info(psb_upd_),check_flag
IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN
SCALE = (UNITD.EQ.'L') ! meaningless SCALE = (UNITD.EQ.'L') ! meaningless
@ -221,16 +221,16 @@ C ... Insert other element of row ...
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM_CSR = ELEM_CSR+1 ELEM_CSR = ELEM_CSR+1
ELSE ELSE
IF (CHECK_FLAG.EQ.1) THEN IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ... C ... Error, there are duplicated elements ...
IERROR = 130 IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999 GOTO 9999
ELSE IF (CHECK_FLAG.EQ.2) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ... C ... Insert only the last duplicated element ...
ARN(ELEM_CSR-1) = AR(ELEM) ARN(ELEM_CSR-1) = AR(ELEM)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
ELSE IF (CHECK_FLAG.EQ.3) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ... C ... Sum the duplicated element ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
@ -296,17 +296,17 @@ C ... Insert other element of row ...
ARN(ELEM_CSR) = AR(ELEM) ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1 ELEM_CSR = ELEM_CSR+1
ELSE ELSE
IF (CHECK_FLAG.EQ.1) THEN IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ... C ... Error, there are duplicated elements ...
IERROR = 130 IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999 GOTO 9999
ELSE IF (CHECK_FLAG.EQ.2) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ... C ... Insert only the last duplicated element ...
ARN(ELEM_CSR-1) = AR(ELEM) ARN(ELEM_CSR-1) = AR(ELEM)
if (debug) write(0,*) 'Duplicated overwrite', if (debug) write(0,*) 'Duplicated overwrite',
+ elem_csr-1,elem + elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.3) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ... C ... Sum the duplicated element ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
if (debug) write(0,*) 'Duplicated add', if (debug) write(0,*) 'Duplicated add',
@ -396,19 +396,19 @@ C ... Insert other element of row ...
ELEM_CSR = ELEM_CSR+1 ELEM_CSR = ELEM_CSR+1
ENDIF ENDIF
ELSE ELSE
IF (CHECK_FLAG.EQ.1) THEN IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ... C ... Error, there are duplicated elements ...
IERROR = 130 IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999 GOTO 9999
ELSE IF (CHECK_FLAG.EQ.2) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ... C ... Insert only the last duplicated element ...
IF(JA(ELEM).GT.IA(ELEM)) THEN IF(JA(ELEM).GT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = AR(ELEM) ARN(ELEM_CSR-1) = AR(ELEM)
ENDIF ENDIF
if (debug) write(0,*) 'Duplicated overwrite', if (debug) write(0,*) 'Duplicated overwrite',
+ elem_csr-1,elem + elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.3) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ... C ... Sum the duplicated element ...
IF(JA(ELEM).GT.IA(ELEM)) THEN IF(JA(ELEM).GT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
@ -494,19 +494,19 @@ C ... Insert other element of row ...
ELEM_CSR = ELEM_CSR+1 ELEM_CSR = ELEM_CSR+1
ENDIF ENDIF
ELSE ELSE
IF (CHECK_FLAG.EQ.1) THEN IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ... C ... Error, there are duplicated elements ...
IERROR = 130 IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999 GOTO 9999
ELSE IF (CHECK_FLAG.EQ.2) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ... C ... Insert only the last duplicated element ...
IF(JA(ELEM).LT.IA(ELEM)) THEN IF(JA(ELEM).LT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = AR(ELEM) ARN(ELEM_CSR-1) = AR(ELEM)
ENDIF ENDIF
if (debug) write(0,*) 'Duplicated overwrite', if (debug) write(0,*) 'Duplicated overwrite',
+ elem_csr-1,elem + elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.3) THEN ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ... C ... Sum the duplicated element ...
IF(JA(ELEM).LT.IA(ELEM)) THEN IF(JA(ELEM).LT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)

2
src/serial/dp/zgindex.f
Unescape Escape View File

@ -59,7 +59,7 @@ c .. Local Arrays ..
POINT_AR = 1 POINT_AR = 1
POINT_JA = 0 POINT_JA = 0
CHECK_FLAG=IBITS(INFON(PSB_UPD_),1,2) call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60 IERROR = 60

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

@ -49,8 +49,8 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
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,&
& ip1, nzl, err_act, int_err(5) & ip1, nzl, err_act, int_err(5), iupd
logical, parameter :: debug=.true. logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dcoins' name='psb_dcoins'
@ -59,113 +59,124 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
info = 0 info = 0
if (nz <= 0) then if (nz <= 0) then
info = 10 info = 10
int_err(1)=1 int_err(1)=1
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
if (size(ia) < nz) then if (size(ia) < nz) then
info = 35 info = 35
int_err(1)=2 int_err(1)=2
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
if (size(ja) < nz) then if (size(ja) < nz) then
info = 35 info = 35
int_err(1)=3 int_err(1)=3
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
if (size(val) < nz) then if (size(val) < nz) then
info = 35 info = 35
int_err(1)=4 int_err(1)=4
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
!!$ ufida = toupper(a%fida) !!$ ufida = toupper(a%fida)
call touppers(a%fida,ufida) call touppers(a%fida,ufida)
ng = size(gtl) ng = size(gtl)
spstate = a%infoa(psb_state_) spstate = psb_sp_getifld(psb_state_,a,info)
select case(spstate) select case(spstate)
case(psb_spmat_bld_) case(psb_spmat_bld_)
if ((ufida /= 'COO').and.(ufida/='COI')) then if ((ufida /= 'COO').and.(ufida/='COI')) then
info = 134 info = 134
ch_err(1:3)=ufida(1:3) ch_err(1:3)=ufida(1:3)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
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.ne.izero) then if(info.ne.izero) then
info=4010 info=4010
ch_err='psb_spinfo' 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
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.ne.izero) then if(info.ne.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,gtl,&
& imin,imax,jmin,jmax,info)
if(info.ne.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 call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,gtl,&
write(0,*) 'PSB_COINS: insert discarded items ' & imin,imax,jmin,jmax,info)
end if if(info.ne.izero) then
end if info=4010
if ((nza - a%infoa(psb_nnz_)) /= nz) then ch_err='psb_inner_ins'
a%infoa(psb_del_bnd_) = nza call psb_errpush(info,name,a_err=ch_err)
endif goto 9999
a%infoa(psb_nnz_) = nza endif
if (debug) then
if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items '
end if
end if
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_) case(psb_spmat_upd_)
if (ibits(a%infoa(psb_upd_),2,1).eq.1) then iupd = psb_sp_getifld(psb_upd_,a,info)
ip1 = a%infoa(psb_upd_pnt_) select case (iupd)
nza = a%ia2(ip1+psb_nnz_) case (psb_upd_perm_)
nzl = a%infoa(psb_del_bnd_) ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,& nza = a%ia2(ip1+psb_nnz_)
& imin,imax,jmin,jmax,nzl,info)
if(info.ne.izero) then call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,&
info=4010 & imin,imax,jmin,jmax,nzl,info)
ch_err='psb_inner_upd'
call psb_errpush(info,name,a_err=ch_err) if(info.ne.izero) then
goto 9999 info=4010
endif ch_err='psb_inner_upd'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
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 '
end if end if
end if end if
a%ia2(ip1+psb_nnz_) = nza
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
a%ia2(ip1+psb_nnz_) = nza case (psb_upd_dflt_, psb_upd_srch_)
else write(0,*) 'Default & search inner update to be implemented'
info = 2231 info = 2230
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif case default
info = 2231
call psb_errpush(info,name)
goto 9999
end select
case default case default
info = 2232 info = 2232
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end select end select
return return
@ -175,8 +186,8 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error() call psb_error()
return return
end if end if
return return
@ -191,7 +202,7 @@ contains
real(kind(1.d0)), intent(inout) :: aspk(*) real(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info integer, intent(out) :: info
integer :: i,ir,ic integer :: i,ir,ic
info = 0 info = 0
if (nza >= nzl) then if (nza >= nzl) then
@ -213,7 +224,7 @@ contains
end if end if
end do end do
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,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,gtl,&

212
src/serial/psb_dcsdp.f90
Unescape Escape View File

@ -47,6 +47,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_spmat_type use psb_spmat_type
use psb_string_mod
implicit none implicit none
!....Parameters... !....Parameters...
@ -68,13 +69,14 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
Integer, Parameter :: maxtry=8 Integer, Parameter :: maxtry=8
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
interface psb_cest interface psb_cest
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info) subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info)
integer, intent(in) :: m,n,nnz integer, intent(in) :: m,n,nnz
integer, intent(out) :: lia1, lia2, lar, info integer, intent(out) :: lia1, lia2, lar, info
character, intent(inout) :: afmt*5 character, intent(inout) :: afmt*5
character, intent(in) :: up character, intent(in) :: up
end subroutine psb_cest end subroutine psb_cest
end interface end interface
interface psb_spinfo interface psb_spinfo
@ -98,17 +100,17 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
ifc_ = 1 ifc_ = 1
endif endif
if (present(check)) then if (present(check)) then
check_ = check check_ = toupper(check)
else else
check_ = 'N' check_ = 'N'
endif endif
if (present(trans)) then if (present(trans)) then
trans_ = trans trans_ = toupper(trans )
else else
trans_ = 'N' trans_ = 'N'
endif endif
if (present(unitd)) then if (present(unitd)) then
unitd_ = unitd unitd_ = toupper(unitd )
else else
unitd_ = 'U' unitd_ = 'U'
endif endif
@ -132,7 +134,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
endif endif
if((check_=='Y').or.(check_=='C')) then if((check_=='Y').or.(check_=='C')) then
if(a%fida(1:3)=='CSR') then if(toupper(a%fida(1:3))=='CSR') then
call dcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info) call dcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -153,13 +155,14 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
b%k=a%k b%k=a%k
call psb_spinfo(psb_nztotreq_,a,size_req,info) call psb_spinfo(psb_nztotreq_,a,size_req,info)
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!! PULL IUP FROM INFOA FIELD !
iup = iand(b%infoa(psb_upd_),4) iup = psb_sp_getifld(psb_upd_,b,info)
if (iup > 0) then if (iup == psb_upd_perm_) then
up = 'Y' up = 'Y'
else else
up = 'N' up = 'N'
endif endif
n_row=b%m n_row=b%m
n_col=b%k n_col=b%k
call psb_cest(b%fida, n_row,n_col,size_req,& call psb_cest(b%fida, n_row,n_col,size_req,&
@ -185,16 +188,16 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
b%pl(:) = 0 b%pl(:) = 0
b%pr(:) = 0 b%pr(:) = 0
select case (a%fida(1:3))
select case (toupper(a%fida(1:3)))
case ('CSR') case ('CSR')
select case (b%fida(1:3)) select case (toupper(b%fida(1:3)))
case ('CSR') case ('CSR')
@ -281,7 +284,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('COO','COI') case ('COO','COI')
select case (b%fida(1:3)) select case (toupper(b%fida(1:3)))
case ('CSR') case ('CSR')
@ -375,99 +378,116 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
else if (check_=='R') then else if (check_=='R') then
!...Regenerating matrix !...Regenerating matrix
if (b%infoa(psb_state_) /= psb_spmat_upd_) then if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then
info = 8888
call psb_errpush(info,name)
goto 9999
endif
if (ibits(b%infoa(psb_upd_),2,1).eq.0) then
!
! Nothing to be done......
!
info = 8888 info = 8888
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
select case(psb_sp_getifld(psb_upd_,b,info))
if (b%fida(1:3)/='JAD') then case(psb_upd_perm_)
ip1 = b%infoa(psb_upd_pnt_)
ip2 = b%ia2(ip1+psb_ip2_) if (toupper(b%fida(1:3))/='JAD') then
nnz = b%ia2(ip1+psb_nnz_) ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
iflag = b%ia2(ip1+psb_iflag_) ip2 = b%ia2(ip1+psb_ip2_)
ichk = b%ia2(ip1+psb_ichk_) nnz = b%ia2(ip1+psb_nnz_)
nnzt = b%ia2(ip1+psb_nnzt_) iflag = b%ia2(ip1+psb_iflag_)
if (debug) write(*,*) 'Regeneration start: ',& ichk = b%ia2(ip1+psb_ichk_)
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,info nnzt = b%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
info = 8889
write(*,*) 'Regeneration start error: ',& if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk info = 8889
call psb_errpush(info,name) write(*,*) 'Regeneration start error: ',&
goto 9999 & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
endif call psb_errpush(info,name)
do i= 1, nnz goto 9999
work(i) = 0.d0 endif
enddo do i= 1, nnz
if (iflag.eq.2) then work(i) = 0.d0
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i)
enddo enddo
else if (iflag.eq.3) then select case(iflag)
do i=1, nnz case(psb_dupl_ovwrt_,psb_dupl_err_)
work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1)) do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
b%aspk(i) = work(i)
enddo enddo
endif
do i=1, nnz
b%aspk(i) = work(i)
enddo
else if (b%fida(1:3) == 'JAD') then
ip1 = b%infoa(psb_upd_pnt_)
ip2 = b%ia1(ip1+psb_ip2_)
count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
nnz = b%ia1(ip1+psb_nnz_)
iflag = b%ia1(ip1+psb_iflag_)
ichk = b%ia1(ip1+psb_ichk_)
nnzt = b%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt,count, &
& iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 10
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz+count else if (toupper(b%fida(1:3)) == 'JAD') then
work(i) = 0.d0
enddo
if (iflag.eq.2) then ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
do i=1, nnz ip2 = b%ia1(ip1+psb_ip2_)
work(b%ia1(ip2+i-1)) = b%aspk(i) count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
nnz = b%ia1(ip1+psb_nnz_)
iflag = b%ia1(ip1+psb_iflag_)
ichk = b%ia1(ip1+psb_ichk_)
nnzt = b%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt,count, &
& iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 10
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz+count
work(i) = 0.d0
enddo enddo
else if (iflag.eq.3) then select case(iflag)
do i=1, nnz case(psb_dupl_ovwrt_,psb_dupl_err_)
work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1)) do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz+count
b%aspk(i) = work(i)
enddo enddo
do i=1, count
b%aspk(b%ia1(ipc+i-1)) = 0.d0
end do
endif endif
do i=1, nnz+count
b%aspk(i) = work(i)
enddo
do i=1, count
b%aspk(b%ia1(ipc+i-1)) = 0.d0
end do
endif
case(psb_upd_dflt_,psb_upd_srch_)
! Nothing to be done
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
end if end if
b%infoa(psb_state_) = psb_spmat_asb_ call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

14
src/serial/psb_getifield.f90
Unescape Escape View File

@ -0,0 +1,14 @@
subroutine psb_getifield(val,field,info,isize,ierr)
integer :: val,field,isize,ierr
integer :: info(*)
ierr = 0
val = -1
if ((field < 1).or.(field > isize)) then
ierr = -1
return
endif
val = info(field)
return
end subroutine psb_getifield

14
src/serial/psb_setifield.f90
Unescape Escape View File

@ -0,0 +1,14 @@
subroutine psb_setifield(val,field,info,isize,ierr)
integer :: val,field,isize,ierr
integer :: info(*)
ierr = 0
if ((field < 1).or.(field > isize)) then
ierr = -1
return
endif
info(field) = val
return
end subroutine psb_setifield

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

@ -49,7 +49,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
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,&
& ip1, nzl, err_act, int_err(5) & ip1, nzl, err_act, int_err(5), iupd
logical, parameter :: debug=.true. logical, parameter :: debug=.true.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -59,113 +59,120 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
info = 0 info = 0
if (nz <= 0) then if (nz <= 0) then
info = 10 info = 10
int_err(1)=1 int_err(1)=1
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
if (size(ia) < nz) then if (size(ia) < nz) then
info = 35 info = 35
int_err(1)=2 int_err(1)=2
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
if (size(ja) < nz) then if (size(ja) < nz) then
info = 35 info = 35
int_err(1)=3 int_err(1)=3
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
if (size(val) < nz) then if (size(val) < nz) then
info = 35 info = 35
int_err(1)=4 int_err(1)=4
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
!!$ ufida = toupper(a%fida) !!$ ufida = toupper(a%fida)
call touppers(a%fida,ufida) call touppers(a%fida,ufida)
ng = size(gtl) ng = size(gtl)
spstate = a%infoa(psb_state_) spstate = psb_sp_getifld(psb_state_,a,info)
select case(spstate) select case(spstate)
case(psb_spmat_bld_) case(psb_spmat_bld_)
if ((ufida /= 'COO').and.(ufida/='COI')) then if ((ufida /= 'COO').and.(ufida/='COI')) then
info = 134 info = 134
ch_err(1:3)=ufida(1:3) ch_err(1:3)=ufida(1:3)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
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.ne.izero) then if(info.ne.izero) then
info=4010 info=4010
ch_err='psb_spinfo' 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
if ((nza+nz)>isza) then if ((nza+nz)>isza) then
call psb_sp_reall(a,nza+nz,info) call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info)
if(info.ne.izero) then if(info.ne.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,gtl,&
& imin,imax,jmin,jmax,info)
if(info.ne.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 call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,gtl,&
write(0,*) 'PSB_COINS: insert discarded items ' & imin,imax,jmin,jmax,info)
end if if(info.ne.izero) then
end if info=4010
if ((nza - a%infoa(psb_nnz_)) /= nz) then ch_err='psb_inner_ins'
a%infoa(psb_del_bnd_) = nza call psb_errpush(info,name,a_err=ch_err)
endif goto 9999
a%infoa(psb_nnz_) = nza endif
if (debug) then
if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items '
end if
end if
if ((nza - a%infoa(psb_nnz_)) /= nz) then
a%infoa(psb_del_bnd_) = nza
endif
a%infoa(psb_nnz_) = nza
case(psb_spmat_upd_) case(psb_spmat_upd_)
if (ibits(a%infoa(psb_upd_),2,1).eq.1) then iupd = psb_sp_getifld(psb_upd_,a,info)
ip1 = a%infoa(psb_upd_pnt_) select case (iupd)
nza = a%ia2(ip1+psb_nnz_) case (psb_upd_perm_)
nzl = a%infoa(psb_del_bnd_) ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,& nza = a%ia2(ip1+psb_nnz_)
& imin,imax,jmin,jmax,nzl,info)
if(info.ne.izero) then call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,&
info=4010 & imin,imax,jmin,jmax,nzl,info)
ch_err='psb_inner_upd' if(info.ne.izero) then
call psb_errpush(info,name,a_err=ch_err) info=4010
goto 9999 ch_err='psb_inner_upd'
endif call psb_errpush(info,name,a_err=ch_err)
goto 9999
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 '
end if end if
end if end if
a%ia2(ip1+psb_nnz_) = nza a%ia2(ip1+psb_nnz_) = nza
else case (psb_upd_dflt_, psb_upd_srch_)
info = 2231 write(0,*) 'Default & search inner update to be implemented'
call psb_errpush(info,name) info = 2230
goto 9999 call psb_errpush(info,name)
endif goto 9999
case default
info = 2231
call psb_errpush(info,name)
goto 9999
end select
case default case default
info = 2232 info = 2232
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end select end select
return return
@ -175,8 +182,8 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error() call psb_error()
return return
end if end if
return return
@ -191,13 +198,13 @@ contains
complex(kind(1.d0)), intent(inout) :: aspk(*) complex(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info integer, intent(out) :: info
integer :: i,ir,ic integer :: i,ir,ic
info = 0 info = 0
if (nza >= nzl) then if (nza >= nzl) then
do i=1, nz do i=1, nz
nza = nza + 1 nza = nza + 1
a%aspk(nza) = val(i) aspk(nza) = val(i)
end do end do
else else
do i=1, nz do i=1, nz
@ -208,12 +215,12 @@ 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
a%aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end if end if
end do end do
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,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,gtl,&
@ -239,9 +246,9 @@ 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
a%ia1(nza) = ir ia1(nza) = ir
a%ia2(nza) = ic ia2(nza) = ic
a%aspk(nza) = val(i) aspk(nza) = val(i)
end if end if
end if end if
end do end do

211
src/serial/psb_zcsdp.f90
Unescape Escape View File

@ -47,6 +47,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_spmat_type use psb_spmat_type
use psb_string_mod
implicit none implicit none
!....Parameters... !....Parameters...
@ -70,12 +71,12 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
interface psb_cest interface psb_cest
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info) subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info)
integer, intent(in) :: m,n,nnz integer, intent(in) :: m,n,nnz
integer, intent(out) :: lia1, lia2, lar, info integer, intent(out) :: lia1, lia2, lar, info
character, intent(inout) :: afmt*5 character, intent(inout) :: afmt*5
character, intent(in) :: up character, intent(in) :: up
end subroutine psb_cest end subroutine psb_cest
end interface end interface
interface psb_spinfo interface psb_spinfo
@ -99,17 +100,17 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
ifc_ = 1 ifc_ = 1
endif endif
if (present(check)) then if (present(check)) then
check_ = check check_ = toupper(check)
else else
check_ = 'N' check_ = 'N'
endif endif
if (present(trans)) then if (present(trans)) then
trans_ = trans trans_ = toupper(trans )
else else
trans_ = 'N' trans_ = 'N'
endif endif
if (present(unitd)) then if (present(unitd)) then
unitd_ = unitd unitd_ = toupper(unitd )
else else
unitd_ = 'U' unitd_ = 'U'
endif endif
@ -133,7 +134,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
endif endif
if((check_=='Y').or.(check_=='C')) then if((check_=='Y').or.(check_=='C')) then
if(a%fida(1:3)=='CSR') then if(toupper(a%fida(1:3))=='CSR') then
call zcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info) call zcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -154,13 +155,14 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
b%k=a%k b%k=a%k
call psb_spinfo(psb_nztotreq_,a,size_req,info) call psb_spinfo(psb_nztotreq_,a,size_req,info)
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!! PULL IUP FROM INFOA FIELD !
iup = iand(b%infoa(psb_upd_),4) iup = psb_sp_getifld(psb_upd_,b,info)
if (iup > 0) then if (iup == psb_upd_perm_) then
up = 'Y' up = 'Y'
else else
up = 'N' up = 'N'
endif endif
n_row=b%m n_row=b%m
n_col=b%k n_col=b%k
call psb_cest(b%fida, n_row,n_col,size_req,& call psb_cest(b%fida, n_row,n_col,size_req,&
@ -186,16 +188,16 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
b%pl(:) = 0 b%pl(:) = 0
b%pr(:) = 0 b%pr(:) = 0
select case (a%fida(1:3))
select case (toupper(a%fida(1:3)))
case ('CSR') case ('CSR')
select case (b%fida(1:3)) select case (toupper(b%fida(1:3)))
case ('CSR') case ('CSR')
@ -271,7 +273,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
case ('COO','COI') case ('COO','COI')
select case (b%fida(1:3)) select case (toupper(b%fida(1:3)))
case ('CSR') case ('CSR')
@ -361,99 +363,116 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
else if (check_=='R') then else if (check_=='R') then
!...Regenerating matrix !...Regenerating matrix
if (b%infoa(psb_state_) /= psb_spmat_upd_) then if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then
info = 8888
call psb_errpush(info,name)
goto 9999
endif
if (ibits(b%infoa(psb_upd_),2,1).eq.0) then
!
! Nothing to be done......
!
info = 8888 info = 8888
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
select case(psb_sp_getifld(psb_upd_,b,info))
if (b%fida(1:3)/='JAD') then case(psb_upd_perm_)
ip1 = b%infoa(psb_upd_pnt_)
ip2 = b%ia2(ip1+psb_ip2_) if (toupper(b%fida(1:3))/='JAD') then
nnz = b%ia2(ip1+psb_nnz_) ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
iflag = b%ia2(ip1+psb_iflag_) ip2 = b%ia2(ip1+psb_ip2_)
ichk = b%ia2(ip1+psb_ichk_) nnz = b%ia2(ip1+psb_nnz_)
nnzt = b%ia2(ip1+psb_nnzt_) iflag = b%ia2(ip1+psb_iflag_)
if (debug) write(*,*) 'Regeneration start: ',& ichk = b%ia2(ip1+psb_ichk_)
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,info nnzt = b%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
info = 8889
write(*,*) 'Regeneration start error: ',& if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk info = 8889
call psb_errpush(info,name) write(*,*) 'Regeneration start error: ',&
goto 9999 & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
endif call psb_errpush(info,name)
do i= 1, nnz goto 9999
work(i) = 0.d0 endif
enddo do i= 1, nnz
if (iflag.eq.2) then work(i) = 0.d0
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i)
enddo enddo
else if (iflag.eq.3) then select case(iflag)
do i=1, nnz case(psb_dupl_ovwrt_,psb_dupl_err_)
work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1)) do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
b%aspk(i) = work(i)
enddo enddo
endif
do i=1, nnz
b%aspk(i) = work(i)
enddo
else if (b%fida(1:3) == 'JAD') then
ip1 = b%infoa(psb_upd_pnt_)
ip2 = b%ia1(ip1+psb_ip2_)
count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
nnz = b%ia1(ip1+psb_nnz_)
iflag = b%ia1(ip1+psb_iflag_)
ichk = b%ia1(ip1+psb_ichk_)
nnzt = b%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt,count, &
& iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 10
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz+count else if (toupper(b%fida(1:3)) == 'JAD') then
work(i) = 0.d0
enddo
if (iflag.eq.2) then ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
do i=1, nnz ip2 = b%ia1(ip1+psb_ip2_)
work(b%ia1(ip2+i-1)) = b%aspk(i) count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
nnz = b%ia1(ip1+psb_nnz_)
iflag = b%ia1(ip1+psb_iflag_)
ichk = b%ia1(ip1+psb_ichk_)
nnzt = b%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt,count, &
& iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 10
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz+count
work(i) = 0.d0
enddo enddo
else if (iflag.eq.3) then select case(iflag)
do i=1, nnz case(psb_dupl_ovwrt_,psb_dupl_err_)
work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1)) do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz+count
b%aspk(i) = work(i)
enddo enddo
do i=1, count
b%aspk(b%ia1(ipc+i-1)) = 0.d0
end do
endif endif
do i=1, nnz+count
b%aspk(i) = work(i)
enddo
do i=1, count
b%aspk(b%ia1(ipc+i-1)) = 0.d0
end do
endif
case(psb_upd_dflt_,psb_upd_srch_)
! Nothing to be done
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
end if end if
b%infoa(psb_state_) = psb_spmat_asb_ call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

210
src/tools/psb_dins.f90
Unescape Escape View File

@ -45,7 +45,7 @@
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted. ! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,& subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck) & iblck, jblck,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
@ -61,12 +61,13 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
real(kind(1.d0)), intent(in) :: blck(:,:) real(kind(1.d0)), intent(in) :: blck(:,:)
integer,intent(out) :: info integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,err_act,& integer :: icontxt,i,loc_row,glob_row,row,k,err_act,&
& nprocs,mode, loc_cols,col,iblock, jblock, mglob, int_err(5), err & nprocs,mode, loc_cols,col,iblock, jblock, mglob, int_err(5), err
integer :: nprow,npcol, me ,mypcol integer :: nprow,npcol, me ,mypcol,dupl_
character :: temp_descra*11,temp_fida*5 character :: temp_descra*11,temp_fida*5
character(len=20) :: name, char_err character(len=20) :: name, char_err
@ -161,22 +162,52 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
else else
jblock = 1 jblock = 1
endif endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
do i = 1, m select case(dupl_)
!loop over all blck's rows case(psb_dupl_ovwrt_)
! row actual block row do i = 1, m
glob_row=ix+i-1 !loop over all blck's rows
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) ! row actual block row
if (loc_row.ge.1) then glob_row=ix+i-1
! this row belongs to me if (glob_row > mglob) exit
! copy i-th row of block blck in x loc_row=desc_a%glob_to_loc(glob_row)
do col = 1, n if (loc_row.ge.1) then
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1) ! this row belongs to me
enddo ! copy i-th row of block blck in x
end if do col = 1, n
enddo x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -240,7 +271,7 @@ end subroutine psb_dins
! info - integer. Eventually returns an error code ! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,& subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck) & iblck,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
@ -265,10 +296,11 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
real(kind(1.d0)), intent(in) :: blck(:) real(kind(1.d0)), intent(in) :: blck(:)
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,loc_cols,mglob,err_act, int_err(5),err integer :: icontxt,i,loc_row,glob_row,loc_cols,mglob,err_act, int_err(5),err
integer :: nprow,npcol, me ,mypcol, iblock integer :: nprow,npcol, me ,mypcol, iblock, dupl_
character(len=20) :: name, char_err character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -352,21 +384,48 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
iblock = 1 iblock = 1
endif endif
do i = 1, m if (present(dupl)) then
!loop over all blck's rows dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
! row actual block row select case(dupl_)
glob_row=ix+i-1 case(psb_dupl_ovwrt_)
if (glob_row > mglob) exit do i = 1, m
!loop over all blck's rows
loc_row=desc_a%glob_to_loc(glob_row) ! row actual block row
if (loc_row.ge.1) then glob_row=ix+i-1
! this row belongs to me if (glob_row > mglob) exit
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -427,7 +486,7 @@ end subroutine psb_dinsvm
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! insflag - integer(optional). ??? ! insflag - integer(optional). ???
subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,& subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag) & iblck,insflag,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
@ -450,11 +509,12 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,& integer :: icontxt,i,loc_row,glob_row,row,k,&
& loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err & loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err
integer :: nprow,npcol, me ,mypcol integer :: nprow,npcol, me ,mypcol,dupl_
character(len=20) :: name, char_err character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -528,32 +588,70 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
else else
liflag = psb_upd_glbnum_ liflag = psb_upd_glbnum_
end if end if
if (present(dupl)) then
if (liflag == psb_upd_glbnum_) then dupl_ = dupl
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = x(i) + blck(i-ix+1)
enddo
else else
info=-1 dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
case(psb_dupl_ovwrt_)
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = blck(i-ix+1)
enddo
else
info=-1
call psb_errpush(info,name)
goto 9999
endif
case(psb_dupl_add_)
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = x(i) + blck(i-ix+1)
enddo
else
info=-1
call psb_errpush(info,name)
goto 9999
endif
case default
info = 321
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

317
src/tools/psb_dspasb.f90
Unescape Escape View File

@ -42,7 +42,7 @@
! up - character(optional). ??? ! up - character(optional). ???
! dup - integer(optional). ??? ! dup - integer(optional). ???
! !
subroutine psb_dspasb(a,desc_a, info, afmt, up, dup) subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
use psb_descriptor_type use psb_descriptor_type
use psb_spmat_type use psb_spmat_type
@ -50,33 +50,25 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
use psb_const_mod use psb_const_mod
use psi_mod use psi_mod
use psb_error_mod use psb_error_mod
use psb_string_mod
implicit none implicit none
interface psb_cest
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info)
integer, intent(in) :: m,n,nnz
integer, intent(out) :: lia1, lia2, lar, info
character, intent(inout) :: afmt*5
character, intent(in) :: up
end subroutine psb_cest
end interface
!...Parameters.... !...Parameters....
type(psb_dspmat_type), intent (inout) :: a type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
integer,optional, intent(in) :: dup integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5, up character, optional, intent(in) :: afmt*5
!....Locals.... !....Locals....
integer :: int_err(5) integer :: int_err(5)
type(psb_dspmat_type) :: atemp type(psb_dspmat_type) :: atemp
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
integer :: ia1_size,ia2_size,aspk_size,m,i,err,& integer :: ia1_size,ia2_size,aspk_size,m,i,err,&
& nprow,npcol,myrow,mycol ,size_req,idup,n_col,iout, err_act & nprow,npcol,myrow,mycol ,size_req,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j, iupdup integer :: dscstate, spstate, nr,k,j
integer :: upd_, dupl_
integer :: icontxt,temp(2),isize(2),n_row integer :: icontxt,temp(2),isize(2),n_row
character :: iup
logical, parameter :: debug=.false., debugwrt=.false. logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -93,21 +85,21 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
! check on BLACS grid ! check on BLACS grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol /= 1) then else if (npcol /= 1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (.not.psb_is_asb_dec(dscstate)) then if (.not.psb_is_asb_dec(dscstate)) then
info = 600 info = 600
int_err(1) = dscstate int_err(1) = dscstate
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (debug) Write (*, *) ' Begin matrix assembly...' if (debug) Write (*, *) ' Begin matrix assembly...'
@ -116,165 +108,128 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
spstate = a%infoa(psb_state_) spstate = a%infoa(psb_state_)
if (spstate == psb_spmat_bld_) then if (spstate == psb_spmat_bld_) then
! !
! First case: we come from a fresh build. ! First case: we come from a fresh build.
! !
n_row = desc_a%matrix_data(psb_n_row_) n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
! !
! Second step: handle the local matrix part. ! Second step: handle the local matrix part.
! !
iupdup = 0 if (present(upd)) then
if (present(up)) then upd_=upd
if(up.eq.'Y') then else
iupdup = 4 upd_ = psb_upd_dflt_
iup = up endif
else if (up /= 'N') then
write(0,*)'Wrong value for update input in ASB...' if (present(dupl)) then
write(0,*)'Changing to default' if((dupl < psb_dupl_ovwrt_).or.(dupl > psb_dupl_err_)) then
iup = 'N' write(0,*)'Wrong value for duplicate input in ASB...'
else write(0,*)'Changing to default'
iup = 'N' dupl_ = psb_dupl_def_
endif else
else dupl_ = dupl
iup = 'N' endif
endif else
dupl_ = psb_dupl_def_
if (present(dup)) then endif
if((dup.lt.1).or.(dup.gt.3)) then
write(0,*)'Wrong value for duplicate input in ASB...'
write(0,*)'Changing to default' call psb_sp_setifld(upd_,psb_upd_,a,info)
idup = 1 call psb_sp_setifld(dupl_,psb_dupl_,a,info)
else
idup = dup a%m = n_row
endif a%k = n_col
else
idup = 1 call psb_sp_clone(a,atemp,info)
endif if(info /= no_err) then
iupdup = ieor(iupdup,idup) info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
a%infoa(psb_upd_)=iupdup goto 9999
if (debug) write(0,*)'in ASB',psb_upd_,iupdup ! convert to user requested format after the temp copy
end if
a%m = n_row
a%k = n_col if (present(afmt)) then
a%fida = afmt
call psb_sp_clone(a,atemp,info) else
if(info /= no_err) then a%fida = '???'
info=4010 endif
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err) if (debugwrt) then
goto 9999 iout = 30+myrow
! convert to user requested format after the temp copy open(iout)
end if call psb_csprt(iout,atemp,head='Input mat')
if (present(afmt)) then close(iout)
a%fida = afmt endif
else
a%fida = '???' ! Do the real conversion into the requested storage format
endif ! result is put in A
call psb_csdp(atemp,a,info,ifc=2)
!
! work area requested must be fixed to IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
! No of Grid'd processes and NNZ+2 if (info /= no_err) then
! info=4010
!!$ size_req = max(a%infoa(psb_nnz_),1)+3 ch_err='psb_csdp'
!!$ if (debug) write(0,*) 'DCSDP : size_req 1:',size_req call psb_errpush(info,name,a_err=ch_err)
!!$ call psb_cest(a%fida, n_row,n_col,size_req,& goto 9999
!!$ & ia1_size, ia2_size, aspk_size, iup,info) endif
!!$ write(0,*) 'ESTIMATE : ',ia1_size,ia2_size,aspk_Size,iup
!!$ if (info /= no_err) then if (debugwrt) then
!!$ info=4010 iout = 60+myrow
!!$ ch_err='psb_cest' open(iout)
!!$ call psb_errpush(info,name,a_err=ch_err) call psb_csprt(iout,a,head='Output mat')
!!$ goto 9999 close(iout)
!!$ endif endif
!!$
!!$ call psb_sp_reall(a,ia1_size,ia2_size,aspk_size,info) call psb_sp_free(atemp,info)
!!$ if (info /= no_err) then
!!$ info=4010
!!$ ch_err='psb_sp_reall'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ endif
!!$
!!$ a%pl(:) = 0
!!$ a%pr(:) = 0
if (debugwrt) then
iout = 30+myrow
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
! Do the real conversion into the requested storage formatmode
! result is put in A
call psb_csdp(atemp,a,info,ifc=2)
IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= no_err) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+myrow
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
call psb_sp_free(atemp,info)
else if (spstate == psb_spmat_upd_) then else if (spstate == psb_spmat_upd_) then
! !
! Second case: we come from an update loop. ! Second case: we come from an update loop.
! !
! Right now, almost nothing to be done, but this ! Right now, almost nothing to be done, but this
! may change in the future ! may change in the future
! as we revise the implementation of the update routine. ! as we revise the implementation of the update routine.
call psb_sp_all(atemp,1,info) call psb_sp_all(atemp,1,info)
atemp%m=a%m atemp%m=a%m
atemp%k=a%k atemp%k=a%k
! check on allocation ! check on allocation
if (info /= no_err) then if (info /= no_err) then
info=4010 info=4010
ch_err='psb_sp_all' ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
call psb_csdp(atemp,a,info,check='R') call psb_csdp(atemp,a,info,check='R')
! check on error retuned by dcsdp ! check on error retuned by dcsdp
if (info /= no_err) then if (info /= no_err) then
info = 4010 info = 4010
ch_err='psb_csdp90' ch_err='psb_csdp90'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_sp_free(atemp,info) call psb_sp_free(atemp,info)
if (info /= no_err) then if (info /= no_err) then
info = 4010 info = 4010
ch_err='sp_free' ch_err='sp_free'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
else else
info = 600 info = 600
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
endif endif
@ -284,8 +239,8 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return

57
src/tools/psb_dsprn.f90
Unescape Escape View File

@ -73,40 +73,43 @@ Subroutine psb_dsprn(a, desc_a,info)
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (npcol.ne.1) then if (npcol.ne.1) then
info = 2030 info = 2030
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (debug) write(*,*) 'got through igamx2d ' if (debug) write(*,*) 'got through igamx2d '
if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then
info=590 info=590
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (a%infoa(psb_state_) == psb_spmat_asb_) then select case(psb_sp_getifld(psb_state_,a,info))
case(psb_spmat_asb_)
a%aspk(:) = dzero
if (ibits(a%infoa(psb_upd_),2,1)==1) then a%aspk(:) = dzero
if(a%fida(1:3).eq.'JAD') then
a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 if (psb_sp_getifld(psb_upd_,a,info)==psb_upd_perm_) then
else if(a%fida(1:3).eq.'JAD') then
a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
endif else
endif a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
a%infoa(psb_state_) = psb_spmat_upd_ endif
else if (a%infoa(psb_state_) == psb_spmat_bld_) then endif
! in this case do nothing. this allows sprn to be called a%infoa(psb_state_) = psb_spmat_upd_
! right after allocate, with spins doing the right thing. case(psb_spmat_bld_)
! hopefully :-) ! in this case do nothing. this allows sprn to be called
else if (a%infoa(psb_state_) == psb_spmat_upd_) then ! right after allocate, with spins doing the right thing.
! hopefully :-)
else
info=591 case( psb_spmat_upd_)
call psb_errpush(info,name)
endif case default
info=591
call psb_errpush(info,name)
end select
if (info /= 0) goto 9999 if (info /= 0) goto 9999

415
src/tools/psb_iins.f90
Unescape Escape View File

@ -45,13 +45,13 @@
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted. ! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,& subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck) & iblck, jblck,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
implicit none implicit none
!....parameters... !....parameters...
integer, intent(in) :: m,n integer, intent(in) :: m,n
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -60,11 +60,12 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
integer, intent(in) :: blck(:,:) integer, intent(in) :: blck(:,:)
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck,jblck integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,& integer :: icontxt,i,loc_row,glob_row,&
& loc_cols,col,iblock, jblock, mglob & loc_cols,col,iblock, jblock, mglob,dupl_
integer :: nprow,npcol, myrow ,mycol, int_err(5),err_act integer :: nprow,npcol, myrow ,mycol, int_err(5),err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -73,110 +74,138 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
name = 'psb_iins' name = 'psb_iins'
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
info=3110 info=3110
call psb_errpush(info, name) call psb_errpush(info, name)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
if (.not.associated(desc_a%glob_to_loc)) then if (.not.associated(desc_a%glob_to_loc)) then
info=3110 info=3110
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
end if end if
!... check parameters.... !... check parameters....
if (m.lt.0) then if (m.lt.0) then
info = 10 info = 10
int_err(1) = 1 int_err(1) = 1
int_err(2) = m int_err(2) = m
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (n.lt.0) then else if (n.lt.0) then
info = 10 info = 10
int_err(1) = 2 int_err(1) = 2
int_err(2) = n int_err(2) = n
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (ix.lt.1) then else if (ix.lt.1) then
info = 20 info = 20
int_err(1) = 6 int_err(1) = 6
int_err(2) = ix int_err(2) = ix
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (jx.lt.1) then else if (jx.lt.1) then
info = 20 info = 20
int_err(1) = 7 int_err(1) = 7
int_err(2) = jx int_err(2) = jx
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
info = 3110 info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_) int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310 info = 310
int_err(1) = 5 int_err(1) = 5
int_err(2) = 4 int_err(2) = 4
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=2).lt.n) then else if (size(x, dim=2).lt.n) then
! check if dimension of x is greater than dimension of submatrix ! check if dimension of x is greater than dimension of submatrix
! to insert ! to insert
info = 320 info = 320
int_err(1) = 2 int_err(1) = 2
int_err(2) = size(x, dim=2) int_err(2) = size(x, dim=2)
int_err(3) = n int_err(3) = n
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
loc_cols = desc_a%matrix_data(psb_n_col_) loc_cols = desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else else
iblock = 1 iblock = 1
endif endif
if (present(jblck)) then if (present(jblck)) then
jblock = jblck jblock = jblck
else
jblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else else
jblock = 1 dupl_ = psb_dupl_ovwrt_
endif endif
do i = 1, m select case(dupl_)
!loop over all blck's rows case(psb_dupl_ovwrt_)
do i = 1, m
! row actual block row !loop over all blck's rows
glob_row=ix+i-1
if (glob_row > mglob) exit ! row actual block row
loc_row=desc_a%glob_to_loc(glob_row) glob_row=ix+i-1
if (loc_row.ge.1) then if (glob_row > mglob) exit
! this row belongs to me loc_row=desc_a%glob_to_loc(glob_row)
! copy i-th row of block blck in x if (loc_row.ge.1) then
do col = 1, n ! this row belongs to me
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1) ! copy i-th row of block blck in x
enddo do col = 1, n
end if x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1)
enddo enddo
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -184,11 +213,11 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return
end subroutine psb_iins end subroutine psb_iins
@ -238,23 +267,23 @@ end subroutine psb_iins
! info - integer. Eventually returns an error code ! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,& subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
& iblck) & iblck,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
implicit none implicit none
! m rows number of submatrix belonging to blck to be inserted ! m rows number of submatrix belonging to blck to be inserted
! iblck first row of submatrix belonging to blck to be inserted ! iblck first row of submatrix belonging to blck to be inserted
! ix x global-row corresponding to position at which blck submatrix ! ix x global-row corresponding to position at which blck submatrix
! must be inserted ! must be inserted
! jx x global-col corresponding to position at which blck submatrix ! jx x global-col corresponding to position at which blck submatrix
! must be inserted ! must be inserted
!....parameters... !....parameters...
integer, intent(in) :: m integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -263,42 +292,71 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
integer, intent(in) :: blck(:) integer, intent(in) :: blck(:)
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,& integer :: icontxt,i,loc_row,glob_row,&
& loc_cols,iblock, jblock,mglob, err_act, int_err(5) & loc_cols,iblock, jblock,mglob, err_act, int_err(5)
integer :: nprow,npcol, myrow ,mycol integer :: nprow,npcol, myrow ,mycol,dupl_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
name = 'psb_iinsvm' name = 'psb_iinsvm'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
loc_cols=desc_a%matrix_data(psb_n_col_) loc_cols=desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else else
iblock = 1 iblock = 1
endif endif
do i = 1, m if (present(dupl)) then
!loop over all blck's rows dupl_ = dupl
else
! row actual block row dupl_ = psb_dupl_ovwrt_
glob_row=ix+i-1 endif
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) select case(dupl_)
if (loc_row.ge.1) then case(psb_dupl_ovwrt_)
! this row belongs to me do i = 1, m
! copy i-th row of block blck in x !loop over all blck's rows
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if ! row actual block row
enddo glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -306,11 +364,11 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return
end subroutine psb_iinsvm end subroutine psb_iinsvm
@ -356,20 +414,20 @@ end subroutine psb_iinsvm
! info - integer. Eventually returns an error code ! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,& subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
& iblck) & iblck,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
implicit none implicit none
! m rows number of submatrix belonging to blck to be inserted ! m rows number of submatrix belonging to blck to be inserted
! iblck first row of submatrix belonging to blck to be inserted ! iblck first row of submatrix belonging to blck to be inserted
! ix x global-row corresponding to position at which blck submatrix ! ix x global-row corresponding to position at which blck submatrix
! must be inserted ! must be inserted
!....parameters... !....parameters...
integer, intent(in) :: m integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -378,11 +436,12 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(in) :: blck(:) integer, intent(in) :: blck(:)
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,k,& integer :: icontxt,i,loc_row,glob_row,k,&
& loc_rows,loc_cols,col,iblock, jblock, mglob, err_act, int_err(5) & loc_rows,loc_cols,col,iblock, jblock, mglob, err_act, int_err(5)
integer :: nprow,npcol, myrow ,mycol integer :: nprow,npcol, myrow ,mycol,dupl_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -391,55 +450,55 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
if (.not.associated(desc_a%glob_to_loc)) then if (.not.associated(desc_a%glob_to_loc)) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
!... check parameters.... !... check parameters....
if (m.lt.0) then if (m.lt.0) then
info = 10 info = 10
int_err(1) = 1 int_err(1) = 1
int_err(2) = m int_err(2) = m
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (ix.lt.1) then else if (ix.lt.1) then
info = 20 info = 20
int_err(1) = 6 int_err(1) = 6
int_err(2) = ix int_err(2) = ix
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
info = 3110 info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_) int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310 info = 310
int_err(1) = 5 int_err(1) = 5
int_err(2) = 4 int_err(2) = 4
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
loc_rows=desc_a%matrix_data(psb_n_row_) loc_rows=desc_a%matrix_data(psb_n_row_)
@ -447,34 +506,62 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else else
iblock = 1 iblock = 1
endif endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
do i = 1, m select case(dupl_)
!loop over all blck's rows case(psb_dupl_ovwrt_)
do i = 1, m
! row actual block row !loop over all blck's rows
glob_row=ix+i-1
if (glob_row > mglob) exit ! row actual block row
glob_row=ix+i-1
loc_row=desc_a%glob_to_loc(glob_row) if (glob_row > mglob) exit
if (loc_row.ge.1) then
! this row belongs to me loc_row=desc_a%glob_to_loc(glob_row)
! copy i-th row of block blck in x if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1) x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if end if
enddo enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(icontxt) call psb_error(icontxt)
return return
end if end if
return return

495
src/tools/psb_zins.f90
Unescape Escape View File

@ -45,7 +45,7 @@
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted. ! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,& subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck) & iblck, jblck,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
@ -61,12 +61,13 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
complex(kind(1.d0)), intent(in) :: blck(:,:) complex(kind(1.d0)), intent(in) :: blck(:,:)
integer,intent(out) :: info integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,err_act,& integer :: icontxt,i,loc_row,glob_row,row,k,err_act,&
& nprocs,mode, loc_cols,col,iblock, jblock, mglob, int_err(5), err & nprocs,mode, loc_cols,col,iblock, jblock, mglob, int_err(5), err
integer :: nprow,npcol, me ,mypcol integer :: nprow,npcol, me ,mypcol,dupl_
character :: temp_descra*11,temp_fida*5 character :: temp_descra*11,temp_fida*5
character(len=20) :: name, char_err character(len=20) :: name, char_err
@ -76,14 +77,14 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
name = 'psb_zins' name = 'psb_zins'
if (.not.associated(desc_a%glob_to_loc)) then if (.not.associated(desc_a%glob_to_loc)) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110 int_err(1)=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -91,92 +92,120 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
!... check parameters.... !... check parameters....
if (m.lt.0) then if (m.lt.0) then
info = 10 info = 10
int_err(1) = 1 int_err(1) = 1
int_err(2) = m int_err(2) = m
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (n.lt.0) then else if (n.lt.0) then
info = 10 info = 10
int_err(1) = 2 int_err(1) = 2
int_err(2) = n int_err(2) = n
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (ix.lt.1) then else if (ix.lt.1) then
info = 20 info = 20
int_err(1) = 6 int_err(1) = 6
int_err(2) = ix int_err(2) = ix
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (jx.lt.1) then else if (jx.lt.1) then
info = 20 info = 20
int_err(1) = 7 int_err(1) = 7
int_err(2) = jx int_err(2) = jx
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
info = 3110 info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_) int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310 info = 310
int_err(1) = 5 int_err(1) = 5
int_err(2) = 4 int_err(2) = 4
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=2).lt.n) then else if (size(x, dim=2).lt.n) then
! check if dimension of x is greater than dimension of submatrix ! check if dimension of x is greater than dimension of submatrix
! to insert ! to insert
info = 320 info = 320
int_err(1) = 2 int_err(1) = 2
int_err(2) = size(x, dim=2) int_err(2) = size(x, dim=2)
int_err(3) = n int_err(3) = n
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
loc_cols = desc_a%matrix_data(psb_n_col_) loc_cols = desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else else
iblock = 1 iblock = 1
endif endif
if (present(jblck)) then if (present(jblck)) then
jblock = jblck jblock = jblck
else else
jblock = 1 jblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif endif
do i = 1, m select case(dupl_)
!loop over all blck's rows case(psb_dupl_ovwrt_)
do i = 1, m
! row actual block row !loop over all blck's rows
glob_row=ix+i-1
if (glob_row > mglob) exit ! row actual block row
loc_row=desc_a%glob_to_loc(glob_row) glob_row=ix+i-1
if (loc_row.ge.1) then if (glob_row > mglob) exit
! this row belongs to me loc_row=desc_a%glob_to_loc(glob_row)
! copy i-th row of block blck in x if (loc_row.ge.1) then
do col = 1, n ! this row belongs to me
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1) ! copy i-th row of block blck in x
enddo do col = 1, n
end if x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1)
enddo enddo
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -185,9 +214,9 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(icontxt)
end if end if
return return
@ -240,7 +269,7 @@ end subroutine psb_zins
! info - integer. Eventually returns an error code ! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,& subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck) & iblck,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
@ -265,10 +294,11 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
complex(kind(1.d0)), intent(in) :: blck(:) complex(kind(1.d0)), intent(in) :: blck(:)
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,loc_cols,mglob,err_act, int_err(5),err integer :: icontxt,i,loc_row,glob_row,loc_cols,mglob,err_act, int_err(5),err
integer :: nprow,npcol, me ,mypcol, iblock integer :: nprow,npcol, me ,mypcol, iblock,dupl_
character(len=20) :: name, char_err character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -277,14 +307,14 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
name = 'psb_zinsvm' name = 'psb_zinsvm'
if (.not.associated(desc_a%glob_to_loc)) then if (.not.associated(desc_a%glob_to_loc)) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110 int_err(1)=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -292,80 +322,107 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
!... check parameters.... !... check parameters....
if (m.lt.0) then if (m.lt.0) then
info = 10 info = 10
int_err(1) = 1 int_err(1) = 1
int_err(2) = m int_err(2) = m
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (ix.lt.1) then else if (ix.lt.1) then
info = 20 info = 20
int_err(1) = 6 int_err(1) = 6
int_err(2) = ix int_err(2) = ix
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (jx.lt.1) then else if (jx.lt.1) then
info = 20 info = 20
int_err(1) = 7 int_err(1) = 7
int_err(2) = jx int_err(2) = jx
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
info = 3110 info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_) int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310 info = 310
int_err(1) = 5 int_err(1) = 5
int_err(2) = 4 int_err(2) = 4
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=2).lt.1) then else if (size(x, dim=2).lt.1) then
! check if dimension of x is greater than dimension of submatrix ! check if dimension of x is greater than dimension of submatrix
! to insert ! to insert
info = 320 info = 320
int_err(1) = 2 int_err(1) = 2
int_err(2) = size(x, dim=2) int_err(2) = size(x, dim=2)
int_err(3) = 1 int_err(3) = 1
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
loc_cols=desc_a%matrix_data(psb_n_col_) loc_cols=desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else
iblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else else
iblock = 1 dupl_ = psb_dupl_ovwrt_
endif endif
do i = 1, m select case(dupl_)
!loop over all blck's rows case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1) x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if end if
enddo enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -374,9 +431,9 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(icontxt)
end if end if
return return
@ -427,7 +484,7 @@ end subroutine psb_zinsvm
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted. ! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! insflag - integer(optional). ??? ! insflag - integer(optional). ???
subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,& subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag) & iblck,insflag,dupl)
!....insert dense submatrix to dense matrix ..... !....insert dense submatrix to dense matrix .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
@ -450,11 +507,12 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(out) :: info integer, intent(out) :: info
integer, optional, intent(in) :: iblck integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
!locals..... !locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,& integer :: icontxt,i,loc_row,glob_row,row,k,&
& loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err & loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err
integer :: nprow,npcol, me ,mypcol integer :: nprow,npcol, me ,mypcol,dupl_
character(len=20) :: name, char_err character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -463,14 +521,14 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
name = 'psb_zinsvv' name = 'psb_zinsvv'
if (.not.associated(desc_a%glob_to_loc)) then if (.not.associated(desc_a%glob_to_loc)) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110 int_err(1)=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -478,40 +536,40 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
!... check parameters.... !... check parameters....
if (m.lt.0) then if (m.lt.0) then
info = 10 info = 10
int_err(1) = 1 int_err(1) = 1
int_err(2) = m int_err(2) = m
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (ix.lt.1) then else if (ix.lt.1) then
info = 20 info = 20
int_err(1) = 6 int_err(1) = 6
int_err(2) = ix int_err(2) = ix
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
info = 3110 info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_) int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310 info = 310
int_err(1) = 5 int_err(1) = 5
int_err(2) = 4 int_err(2) = 4
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
loc_rows=desc_a%matrix_data(psb_n_row_) loc_rows=desc_a%matrix_data(psb_n_row_)
@ -519,41 +577,80 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else else
iblock = 1 iblock = 1
endif endif
if (present(insflag)) then if (present(insflag)) then
liflag = insflag liflag = insflag
else else
liflag = psb_upd_glbnum_ liflag = psb_upd_glbnum_
end if end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (liflag == psb_upd_glbnum_) then select case(dupl_)
do i = 1, m case(psb_dupl_ovwrt_)
!loop over all blck's rows
! row actual block row if (liflag == psb_upd_glbnum_) then
glob_row=ix+i-1 do i = 1, m
if (glob_row > mglob) exit !loop over all blck's rows
loc_row=desc_a%glob_to_loc(glob_row) ! row actual block row
if (loc_row.ge.1) then glob_row=ix+i-1
! this row belongs to me if (glob_row > mglob) exit
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1) loc_row=desc_a%glob_to_loc(glob_row)
end if if (loc_row.ge.1) then
enddo ! this row belongs to me
else if (liflag == psb_upd_locnum_) then ! copy i-th row of block blck in x
k = min(ix+m-1,loc_rows) x(loc_row) = blck(iblock+i-1)
do i=ix,k end if
x(i) = x(i) + blck(i-ix+1) enddo
enddo else if (liflag == psb_upd_locnum_) then
else k = min(ix+m-1,loc_rows)
info=-1 do i=ix,k
call psb_errpush(info,name) x(i) = blck(i-ix+1)
goto 9999 enddo
endif else
info=-1
call psb_errpush(info,name)
goto 9999
endif
case(psb_dupl_add_)
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = x(i) + blck(i-ix+1)
enddo
else
info=-1
call psb_errpush(info,name)
goto 9999
endif
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -562,9 +659,9 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(icontxt)
end if end if
return return

209
src/tools/psb_zspasb.f90
Unescape Escape View File

@ -42,7 +42,7 @@
! up - character(optional). ??? ! up - character(optional). ???
! dup - integer(optional). ??? ! dup - integer(optional). ???
! !
subroutine psb_zspasb(a,desc_a, info, afmt, up, dup) subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
use psb_descriptor_type use psb_descriptor_type
use psb_spmat_type use psb_spmat_type
@ -50,33 +50,25 @@ subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
use psb_const_mod use psb_const_mod
use psi_mod use psi_mod
use psb_error_mod use psb_error_mod
use psb_string_mod
implicit none implicit none
interface psb_cest
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info)
integer, intent(in) :: m,n,nnz
integer, intent(out) :: lia1, lia2, lar, info
character, intent(inout) :: afmt*5
character, intent(in) :: up
end subroutine psb_cest
end interface
!...Parameters.... !...Parameters....
type(psb_zspmat_type), intent (inout) :: a type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
integer,optional, intent(in) :: dup integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5, up character, optional, intent(in) :: afmt*5
!....Locals.... !....Locals....
integer :: int_err(5) integer :: int_err(5)
type(psb_zspmat_type) :: atemp type(psb_zspmat_type) :: atemp
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
integer :: ia1_size,ia2_size,aspk_size,m,i,err,& integer :: ia1_size,ia2_size,aspk_size,m,i,err,&
& nprow,npcol,myrow,mycol ,size_req,idup,n_col,iout, err_act & nprow,npcol,myrow,mycol ,size_req,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j, iupdup integer :: dscstate, spstate, nr,k,j
integer :: upd_, dupl_
integer :: icontxt,temp(2),isize(2),n_row integer :: icontxt,temp(2),isize(2),n_row
character :: iup
logical, parameter :: debug=.false., debugwrt=.false. logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -116,118 +108,81 @@ subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
spstate = a%infoa(psb_state_) spstate = a%infoa(psb_state_)
if (spstate == psb_spmat_bld_) then if (spstate == psb_spmat_bld_) then
! !
! First case: we come from a fresh build. ! First case: we come from a fresh build.
! !
n_row = desc_a%matrix_data(psb_n_row_) n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
! !
! Second step: handle the local matrix part. ! Second step: handle the local matrix part.
! !
iupdup = 0 if (present(upd)) then
if (present(up)) then upd_=upd
if(up.eq.'Y') then else
iupdup = 4 upd_ = psb_upd_dflt_
iup = up endif
else if (up /= 'N') then
write(0,*)'Wrong value for update input in ASB...' if (present(dupl)) then
write(0,*)'Changing to default' if((dupl < psb_dupl_ovwrt_).or.(dupl > psb_dupl_err_)) then
iup = 'N' write(0,*)'Wrong value for duplicate input in ASB...'
else write(0,*)'Changing to default'
iup = 'N' dupl_ = psb_dupl_def_
endif else
else dupl_ = dupl
iup = 'N' endif
endif else
dupl_ = psb_dupl_def_
if (present(dup)) then endif
if((dup.lt.1).or.(dup.gt.3)) then
write(0,*)'Wrong value for duplicate input in ASB...'
write(0,*)'Changing to default' call psb_sp_setifld(upd_,psb_upd_,a,info)
idup = 1 call psb_sp_setifld(dupl_,psb_dupl_,a,info)
else
idup = dup a%m = n_row
endif a%k = n_col
else
idup = 1 call psb_sp_clone(a,atemp,info)
endif if(info /= no_err) then
iupdup = ieor(iupdup,idup) info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
a%infoa(psb_upd_)=iupdup goto 9999
if (debug) write(0,*)'in ASB',psb_upd_,iupdup ! convert to user requested format after the temp copy
end if
a%m = n_row
a%k = n_col if (present(afmt)) then
a%fida = afmt
call psb_sp_clone(a,atemp,info) else
if(info /= no_err) then a%fida = '???'
info=4010 endif
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err) if (debugwrt) then
goto 9999 iout = 30+myrow
! convert to user requested format after the temp copy open(iout)
end if call psb_csprt(iout,atemp,head='Input mat')
if (present(afmt)) then close(iout)
a%fida = afmt endif
else
a%fida = '???' ! Do the real conversion into the requested storage format
endif ! result is put in A
call psb_csdp(atemp,a,info,ifc=2)
!
! work area requested must be fixed to IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
! No of Grid'd processes and NNZ+2 if (info /= no_err) then
! info=4010
!!$ size_req = max(a%infoa(psb_nnz_),1)+3 ch_err='psb_csdp'
!!$ if (debug) write(0,*) 'DCSDP : size_req 1:',size_req call psb_errpush(info,name,a_err=ch_err)
!!$ call psb_cest(a%fida, n_row,n_col,size_req,& goto 9999
!!$ & ia1_size, ia2_size, aspk_size, iup,info) endif
!!$ write(0,*) 'ESTIMATE : ',ia1_size,ia2_size,aspk_Size,iup
!!$ if (info /= no_err) then if (debugwrt) then
!!$ info=4010 iout = 60+myrow
!!$ ch_err='psb_cest' open(iout)
!!$ call psb_errpush(info,name,a_err=ch_err) call psb_csprt(iout,a,head='Output mat')
!!$ goto 9999 close(iout)
!!$ endif endif
!!$
!!$ call psb_sp_reall(a,ia1_size,ia2_size,aspk_size,info)
!!$ if (info /= no_err) then
!!$ info=4010
!!$ ch_err='psb_sp_reall'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ endif
!!$
!!$ a%pl(:) = 0
!!$ a%pr(:) = 0
if (debugwrt) then
iout = 30+myrow
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
! Do the real conversion into the requested storage formatmode
! result is put in A
call psb_csdp(atemp,a,info,ifc=2)
IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= no_err) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+myrow
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
call psb_sp_free(atemp,info) call psb_sp_free(atemp,info)

12
test/Fileread/mat_dist.f90
Unescape Escape View File

@ -420,7 +420,7 @@ contains
call blacs_barrier(icontxt,'all') call blacs_barrier(icontxt,'all')
t2 = mpi_wtime() t2 = mpi_wtime()
call psb_spasb(a,desc_a,info,dup=1,afmt=afmt) call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)
t3 = mpi_wtime() t3 = mpi_wtime()
if(info/=0)then if(info/=0)then
info=4010 info=4010
@ -437,7 +437,7 @@ contains
else else
call psb_spasb(a,desc_a,info,afmt=afmt,dup=1) call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_err_)
if(info/=0)then if(info/=0)then
info=4010 info=4010
ch_err='psspasb' ch_err='psspasb'
@ -780,7 +780,7 @@ contains
call blacs_barrier(icontxt,'all') call blacs_barrier(icontxt,'all')
t2 = mpi_wtime() t2 = mpi_wtime()
call psb_spasb(a,desc_a,info,dup=1,afmt=afmt) call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)
t3 = mpi_wtime() t3 = mpi_wtime()
if(info/=0)then if(info/=0)then
info=4010 info=4010
@ -1203,7 +1203,7 @@ contains
call blacs_barrier(icontxt,'all') call blacs_barrier(icontxt,'all')
t2 = mpi_wtime() t2 = mpi_wtime()
call psb_spasb(a,desc_a,info,dup=1,afmt=afmt) call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)
t3 = mpi_wtime() t3 = mpi_wtime()
if(info/=0)then if(info/=0)then
info=4010 info=4010
@ -1220,7 +1220,7 @@ contains
else else
call psb_spasb(a,desc_a,info,afmt=afmt,dup=1) call psb_spasb(a,desc_a,info,afmt=afmt,dupl=psb_dupl_err_)
if(info/=0)then if(info/=0)then
info=4010 info=4010
ch_err='psspasb' ch_err='psspasb'
@ -1563,7 +1563,7 @@ contains
call blacs_barrier(icontxt,'all') call blacs_barrier(icontxt,'all')
t2 = mpi_wtime() t2 = mpi_wtime()
call psb_spasb(a,desc_a,info,dup=1,afmt=afmt) call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)
t3 = mpi_wtime() t3 = mpi_wtime()
if(info/=0)then if(info/=0)then
info=4010 info=4010

2
test/pargen/ppde90.f90
Unescape Escape View File

@ -667,7 +667,7 @@ contains
t1 = mpi_wtime() t1 = mpi_wtime()
call psb_cdasb(desc_a,info) call psb_cdasb(desc_a,info)
call psb_spasb(a,desc_a,info,dup=1,afmt=afmt) call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)
call blacs_barrier(icontxt,'ALL') call blacs_barrier(icontxt,'ALL')
tasb = mpi_wtime()-t1 tasb = mpi_wtime()-t1
if(info.ne.0) then if(info.ne.0) then

Write Preview
Loading…
Cancel
Save