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
!
integer, parameter :: psb_root_=0
integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2
integer, parameter :: psb_nzsizereq_=3
!
! Entries and values for spmat%info
!
integer, parameter :: psb_nnz_=1, psb_dupl_=5
integer, parameter :: psb_del_bnd_=6, psb_srtd_=7
integer, parameter :: psb_state_=8, psb_upd_=9
integer, parameter :: psb_upd_pnt_=10, psb_ifasize_=10
integer, parameter :: psb_nnz_=1
integer, parameter :: psb_del_bnd_=7, psb_srtd_=8
integer, parameter :: psb_state_=9
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_asb_=2, psb_spmat_upd_=4
integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0
integer, parameter :: psb_iflag_=2, psb_ichk_=3
integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6
integer, parameter :: psb_dupl_err_ =1
integer, parameter :: psb_dupl_ovwrt_=2
integer, parameter :: psb_dupl_add_ =3
integer, parameter :: psb_perm_update_=98765
integer, parameter :: psb_srch_update_=98764
integer, parameter :: psb_isrtdcoo_ =98761
integer, parameter :: psb_dupl_ovwrt_ = 0
integer, parameter :: psb_dupl_add_ = 1
integer, parameter :: psb_dupl_err_ = 2
integer, parameter :: psb_dupl_def_ = psb_dupl_ovwrt_
integer, parameter :: psb_upd_dflt_ = 0
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_dbleint_=2
!

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

@ -92,6 +92,7 @@ Contains
rrax=>tmp
end if
else
dim = 0
allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000

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
character(len=11) :: descra
! Contains some additional informations on sparse matrix
integer :: infoa(10)
integer :: infoa(psb_ifasize_)
! Contains sparse matrix coefficients
real(kind(1.d0)), pointer :: aspk(:)=>null()
! Contains indeces that describes sparse matrix structure
@ -63,7 +63,7 @@ module psb_spmat_type
! describe some chacteristics of sparse matrix
character(len=11) :: descra
! Contains some additional informations on sparse matrix
integer :: infoa(10)
integer :: infoa(psb_ifasize_)
! Contains sparse matrix coefficients
complex(kind(1.d0)), pointer :: aspk(:)=>null()
! Contains indeces that describes sparse matrix structure
@ -80,6 +80,14 @@ module psb_spmat_type
module procedure psb_dspclone, psb_zspclone
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
module procedure psb_dsp_transfer, psb_zsp_transfer
end interface
@ -212,7 +220,7 @@ contains
a%m=max(0,m)
a%k=max(0,k)
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%pr(1)=0
! set infoa fields
@ -296,6 +304,8 @@ contains
call psb_realloc(max(1,a%m),a%pl,info)
if (info /= 0) return
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
Return
@ -420,6 +430,63 @@ contains
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)
implicit none
!....Parameters...
@ -765,6 +832,66 @@ contains
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)
implicit none

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

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

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

@ -165,7 +165,8 @@ contains
goto 9999
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%m=a%m
b%k=a%k

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

@ -165,7 +165,8 @@ contains
goto 9999
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%m=a%m
b%k=a%k

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

@ -509,7 +509,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
liwork= 2*ncol
if (a%pr(1) /= 0) liwork = liwork + n * ik
if (a%pl(1) /= 0) liwork = liwork + m * ik
! write(0,*)'---->>>',work(1)
! write(0,*)'---->>>',work(1)
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work

23
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 psb_check_mod
use psb_error_mod
use psb_string_mod
implicit none
real(kind(1.D0)), intent(in) :: alpha, beta
@ -159,16 +160,16 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
endif
if (present(unitd)) then
lunitd = unitd
lunitd = toupper(unitd)
else
lunitd = 'U'
endif
if (present(trans)) then
if ((trans.eq.'N').or.(trans.eq.'T')&
& .or.(trans.eq.'n').or.(trans.eq.'t')) then
itrans = trans
else if ((trans.eq.'C').or.(trans.eq.'c')) then
itrans = toupper(trans)
if((itrans.eq.'N').or.(itrans.eq.'T')) then
! Ok
else if (itrans.eq.'C') then
info = 3020
call psb_errpush(info,name)
goto 9999
@ -388,6 +389,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
use psi_mod
use psb_check_mod
use psb_error_mod
use psb_string_mod
real(kind(1.D0)), intent(in) :: alpha, beta
real(kind(1.d0)), intent(in), target :: x(:)
@ -448,15 +450,16 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
endif
if (present(unitd)) then
lunitd = unitd
lunitd = toupper(unitd)
else
lunitd = 'U'
endif
if (present(trans)) then
if((trans.eq.'N').or.(trans.eq.'T')) then
itrans = trans
else if (trans.eq.'C') then
itrans = toupper(trans)
if((itrans.eq.'N').or.(itrans.eq.'T')) then
! Ok
else if (itrans.eq.'C') then
info = 3020
call psb_errpush(info,name)
goto 9999
@ -507,7 +510,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
end if
iwork(1)=0.d0
if(present(d)) then
if (present(d)) then
lld = size(d)
id => d
else

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_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.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 .

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

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

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

@ -30,7 +30,8 @@
!!$
! File: imsr.f90
! Subroutine:
! Parameters:subroutine imsr(n,x)
! Parameters:
subroutine imsr(n,x)
integer :: 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
! Subroutine:
! Parameters:subroutine imsrx(n,x,indx)
! Parameters:
subroutine imsrx(n,x,indx)
integer :: n
integer :: x(n)
integer :: indx(n)

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

@ -71,13 +71,14 @@ c
ierror = 0
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
scale = (unitd.eq.'L') ! meaningless
p1(1) = 0
p2(1) = 0
nnz = info(psb_nnz_)
call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror)
if (debug) then
write(*,*) 'on entry to dcoco: nnz laux ',
+ nnz,laux,larn,lia1n,lia2n
@ -171,16 +172,16 @@ c ... insert remaining element ...
do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (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 ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
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 ...
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
else if (check_flag.eq.3) then
c ... sum the duplicated element ...
else if (check_flag.eq.psb_dupl_add_) then
c ... add the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in)
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
end if
@ -219,15 +220,15 @@ c ... insert remaining element ...
do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (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 ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
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 ...
else if (check_flag.eq.3) then
c ... sum the duplicated element ...
else if (check_flag.eq.psb_dupl_add_) then
c ... add the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in)
end if
else

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

@ -73,8 +73,8 @@ C
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
CHECK_FLAG=IBITS(INFO(PSB_UPD_),1,2)
c$$$ write(0,*) 'DCOCR FLAG ',info(psb_upd_),check_flag
call psb_getifield(check_flag,psb_dupl_,info,psb_ifasize_,ierror)
IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN
SCALE = (UNITD.EQ.'L') ! meaningless
@ -221,16 +221,16 @@ C ... Insert other element of row ...
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM_CSR = ELEM_CSR+1
ELSE
IF (CHECK_FLAG.EQ.1) THEN
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
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 ...
ARN(ELEM_CSR-1) = AR(ELEM)
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 ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
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)
ELEM_CSR = ELEM_CSR+1
ELSE
IF (CHECK_FLAG.EQ.1) THEN
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
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 ...
ARN(ELEM_CSR-1) = AR(ELEM)
if (debug) write(0,*) 'Duplicated overwrite',
+ 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 ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
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_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
IERROR = 60

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

@ -71,7 +71,7 @@ c
ierror = 0
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
scale = (unitd.eq.'L') ! meaningless
p1(1) = 0
@ -172,15 +172,15 @@ c ... insert remaining element ...
do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (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 ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
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 ...
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 ...
arn(elem_out) = arn(elem_out) + arn(elem_in)
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
@ -220,14 +220,14 @@ c ... insert remaining element ...
do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (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 ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
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 ...
else if (check_flag.eq.3) then
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in)
end if

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

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

35
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
integer :: i,j,ir,ic,nr,nc, ng, nza, isza,spstate, nnz,&
& ip1, nzl, err_act, int_err(5)
logical, parameter :: debug=.true.
& ip1, nzl, err_act, int_err(5), iupd
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
name='psb_dcoins'
@ -88,9 +88,10 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
!!$ ufida = toupper(a%fida)
call touppers(a%fida,ufida)
ng = size(gtl)
spstate = a%infoa(psb_state_)
spstate = psb_sp_getifld(psb_state_,a,info)
select case(spstate)
case(psb_spmat_bld_)
if ((ufida /= 'COO').and.(ufida/='COI')) then
info = 134
@ -129,20 +130,23 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
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
if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then
call psb_sp_setifld(nza,psb_del_bnd_,a,info)
endif
a%infoa(psb_nnz_) = nza
call psb_sp_setifld(nza,psb_nnz_,a,info)
case(psb_spmat_upd_)
if (ibits(a%infoa(psb_upd_),2,1).eq.1) then
ip1 = a%infoa(psb_upd_pnt_)
iupd = psb_sp_getifld(psb_upd_,a,info)
select case (iupd)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
nzl = a%infoa(psb_del_bnd_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,&
& imin,imax,jmin,jmax,nzl,info)
if(info.ne.izero) then
info=4010
ch_err='psb_inner_upd'
@ -154,13 +158,20 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
write(0,*) 'PSB_COINS: update discarded items '
end if
end if
a%ia2(ip1+psb_nnz_) = nza
else
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
case (psb_upd_dflt_, psb_upd_srch_)
write(0,*) 'Default & search inner update to be implemented'
info = 2230
call psb_errpush(info,name)
goto 9999
case default
info = 2231
call psb_errpush(info,name)
goto 9999
endif
end select
case default
info = 2232

88
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_error_mod
use psb_spmat_type
use psb_string_mod
implicit none
!....Parameters...
@ -68,6 +69,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
Integer, Parameter :: maxtry=8
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
interface psb_cest
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info)
integer, intent(in) :: m,n,nnz
@ -98,17 +100,17 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
ifc_ = 1
endif
if (present(check)) then
check_ = check
check_ = toupper(check)
else
check_ = 'N'
endif
if (present(trans)) then
trans_ = trans
trans_ = toupper(trans )
else
trans_ = 'N'
endif
if (present(unitd)) then
unitd_ = unitd
unitd_ = toupper(unitd )
else
unitd_ = 'U'
endif
@ -132,7 +134,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
endif
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)
if(info /= 0) then
info=4010
@ -153,13 +155,14 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
b%k=a%k
call psb_spinfo(psb_nztotreq_,a,size_req,info)
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!! PULL IUP FROM INFOA FIELD
iup = iand(b%infoa(psb_upd_),4)
if (iup > 0) then
!
iup = psb_sp_getifld(psb_upd_,b,info)
if (iup == psb_upd_perm_) then
up = 'Y'
else
up = 'N'
endif
n_row=b%m
n_col=b%k
call psb_cest(b%fida, n_row,n_col,size_req,&
@ -190,11 +193,11 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
b%pr(:) = 0
select case (a%fida(1:3))
select case (toupper(a%fida(1:3)))
case ('CSR')
select case (b%fida(1:3))
select case (toupper(b%fida(1:3)))
case ('CSR')
@ -281,7 +284,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('COO','COI')
select case (b%fida(1:3))
select case (toupper(b%fida(1:3)))
case ('CSR')
@ -375,57 +378,59 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
else if (check_=='R') then
!...Regenerating matrix
if (b%infoa(psb_state_) /= 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......
!
if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then
info = 8888
call psb_errpush(info,name)
goto 9999
endif
select case(psb_sp_getifld(psb_upd_,b,info))
case(psb_upd_perm_)
if (b%fida(1:3)/='JAD') then
ip1 = b%infoa(psb_upd_pnt_)
if (toupper(b%fida(1:3))/='JAD') then
ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
ip2 = b%ia2(ip1+psb_ip2_)
nnz = b%ia2(ip1+psb_nnz_)
iflag = b%ia2(ip1+psb_iflag_)
ichk = b%ia2(ip1+psb_ichk_)
nnzt = b%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,info
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = 0.d0
enddo
if (iflag.eq.2) then
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i)
enddo
else if (iflag.eq.3) then
case(psb_dupl_add_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1))
enddo
endif
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
b%aspk(i) = work(i)
enddo
else if (b%fida(1:3) == 'JAD') then
else if (toupper(b%fida(1:3)) == 'JAD') then
ip1 = b%infoa(psb_upd_pnt_)
ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
ip2 = b%ia1(ip1+psb_ip2_)
count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
@ -434,13 +439,13 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
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, &
& 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_perm_update_,nnz,nnzt ,iflag,ichk
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
@ -448,15 +453,21 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
do i= 1, nnz+count
work(i) = 0.d0
enddo
if (iflag.eq.2) then
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i)
enddo
else if (iflag.eq.3) then
case(psb_dupl_add_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1))
enddo
endif
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz+count
b%aspk(i) = work(i)
enddo
@ -465,9 +476,18 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
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
b%infoa(psb_state_) = psb_spmat_asb_
call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
call psb_erractionrestore(err_act)
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

33
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
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.
character(len=20) :: name, ch_err
@ -88,7 +88,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
!!$ ufida = toupper(a%fida)
call touppers(a%fida,ufida)
ng = size(gtl)
spstate = a%infoa(psb_state_)
spstate = psb_sp_getifld(psb_state_,a,info)
select case(spstate)
case(psb_spmat_bld_)
@ -108,7 +108,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
endif
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
info=4010
ch_err='psb_sp_reall'
@ -136,10 +136,12 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
case(psb_spmat_upd_)
if (ibits(a%infoa(psb_upd_),2,1).eq.1) then
ip1 = a%infoa(psb_upd_pnt_)
iupd = psb_sp_getifld(psb_upd_,a,info)
select case (iupd)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
nzl = a%infoa(psb_del_bnd_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,&
& imin,imax,jmin,jmax,nzl,info)
@ -156,11 +158,16 @@ subroutine psb_zcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
end if
a%ia2(ip1+psb_nnz_) = nza
else
case (psb_upd_dflt_, psb_upd_srch_)
write(0,*) 'Default & search inner update to be implemented'
info = 2230
call psb_errpush(info,name)
goto 9999
case default
info = 2231
call psb_errpush(info,name)
goto 9999
endif
end select
case default
info = 2232
@ -197,7 +204,7 @@ contains
if (nza >= nzl) then
do i=1, nz
nza = nza + 1
a%aspk(nza) = val(i)
aspk(nza) = val(i)
end do
else
do i=1, nz
@ -208,7 +215,7 @@ contains
ic = gtl(ic)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
a%aspk(nza) = val(i)
aspk(nza) = val(i)
end if
end if
end do
@ -239,9 +246,9 @@ contains
ic = gtl(ic)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
a%ia1(nza) = ir
a%ia2(nza) = ic
a%aspk(nza) = val(i)
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do

87
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_error_mod
use psb_spmat_type
use psb_string_mod
implicit none
!....Parameters...
@ -99,17 +100,17 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
ifc_ = 1
endif
if (present(check)) then
check_ = check
check_ = toupper(check)
else
check_ = 'N'
endif
if (present(trans)) then
trans_ = trans
trans_ = toupper(trans )
else
trans_ = 'N'
endif
if (present(unitd)) then
unitd_ = unitd
unitd_ = toupper(unitd )
else
unitd_ = 'U'
endif
@ -133,7 +134,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
endif
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)
if(info /= 0) then
info=4010
@ -154,13 +155,14 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
b%k=a%k
call psb_spinfo(psb_nztotreq_,a,size_req,info)
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!! PULL IUP FROM INFOA FIELD
iup = iand(b%infoa(psb_upd_),4)
if (iup > 0) then
!
iup = psb_sp_getifld(psb_upd_,b,info)
if (iup == psb_upd_perm_) then
up = 'Y'
else
up = 'N'
endif
n_row=b%m
n_col=b%k
call psb_cest(b%fida, n_row,n_col,size_req,&
@ -191,11 +193,11 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
b%pr(:) = 0
select case (a%fida(1:3))
select case (toupper(a%fida(1:3)))
case ('CSR')
select case (b%fida(1:3))
select case (toupper(b%fida(1:3)))
case ('CSR')
@ -271,7 +273,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
case ('COO','COI')
select case (b%fida(1:3))
select case (toupper(b%fida(1:3)))
case ('CSR')
@ -361,57 +363,59 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
else if (check_=='R') then
!...Regenerating matrix
if (b%infoa(psb_state_) /= 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......
!
if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then
info = 8888
call psb_errpush(info,name)
goto 9999
endif
select case(psb_sp_getifld(psb_upd_,b,info))
case(psb_upd_perm_)
if (b%fida(1:3)/='JAD') then
ip1 = b%infoa(psb_upd_pnt_)
if (toupper(b%fida(1:3))/='JAD') then
ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
ip2 = b%ia2(ip1+psb_ip2_)
nnz = b%ia2(ip1+psb_nnz_)
iflag = b%ia2(ip1+psb_iflag_)
ichk = b%ia2(ip1+psb_ichk_)
nnzt = b%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,info
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = 0.d0
enddo
if (iflag.eq.2) then
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i)
enddo
else if (iflag.eq.3) then
case(psb_dupl_add_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1))
enddo
endif
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
b%aspk(i) = work(i)
enddo
else if (b%fida(1:3) == 'JAD') then
else if (toupper(b%fida(1:3)) == 'JAD') then
ip1 = b%infoa(psb_upd_pnt_)
ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
ip2 = b%ia1(ip1+psb_ip2_)
count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
@ -420,13 +424,13 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
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, &
& 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_perm_update_,nnz,nnzt ,iflag,ichk
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
@ -434,15 +438,21 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
do i= 1, nnz+count
work(i) = 0.d0
enddo
if (iflag.eq.2) then
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i)
enddo
else if (iflag.eq.3) then
case(psb_dupl_add_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1))
enddo
endif
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz+count
b%aspk(i) = work(i)
enddo
@ -451,9 +461,18 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd)
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
b%infoa(psb_state_) = psb_spmat_asb_
call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
call psb_erractionrestore(err_act)
return

112
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.
! 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,&
& iblck, jblck)
& iblck, jblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
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(:,:)
integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,err_act,&
& 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(len=20) :: name, char_err
@ -161,7 +162,32 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
else
jblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
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
do col = 1, n
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
@ -177,6 +203,11 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@ -240,7 +271,7 @@ end subroutine psb_dins
! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck)
& iblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
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(:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals.....
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
if(psb_get_errstatus().ne.0) return
@ -352,6 +384,14 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
iblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all blck's rows
@ -363,10 +403,29 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
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)
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)
return
@ -427,7 +486,7 @@ end subroutine psb_dinsvm
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! insflag - integer(optional). ???
subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag)
& iblck,insflag,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@ -450,11 +509,12 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,&
& 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
if(psb_get_errstatus().ne.0) return
@ -528,7 +588,40 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
else
liflag = psb_upd_glbnum_
end if
if (present(dupl)) then
dupl_ = dupl
else
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
@ -554,6 +647,11 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
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)
return

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

@ -42,7 +42,7 @@
! up - character(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_spmat_type
@ -50,33 +50,25 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
use psb_const_mod
use psi_mod
use psb_error_mod
use psb_string_mod
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....
type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dup
character, optional, intent(in) :: afmt*5, up
integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5
!....Locals....
integer :: int_err(5)
type(psb_dspmat_type) :: atemp
real(kind(1.d0)) :: real_err(5)
integer :: ia1_size,ia2_size,aspk_size,m,i,err,&
& nprow,npcol,myrow,mycol ,size_req,idup,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j, iupdup
& nprow,npcol,myrow,mycol ,size_req,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j
integer :: upd_, dupl_
integer :: icontxt,temp(2),isize(2),n_row
character :: iup
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err
@ -126,38 +118,27 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
!
! Second step: handle the local matrix part.
!
iupdup = 0
if (present(up)) then
if(up.eq.'Y') then
iupdup = 4
iup = up
else if (up /= 'N') then
write(0,*)'Wrong value for update input in ASB...'
write(0,*)'Changing to default'
iup = 'N'
if (present(upd)) then
upd_=upd
else
iup = 'N'
endif
else
iup = 'N'
upd_ = psb_upd_dflt_
endif
if (present(dup)) then
if((dup.lt.1).or.(dup.gt.3)) then
if (present(dupl)) then
if((dupl < psb_dupl_ovwrt_).or.(dupl > psb_dupl_err_)) then
write(0,*)'Wrong value for duplicate input in ASB...'
write(0,*)'Changing to default'
idup = 1
dupl_ = psb_dupl_def_
else
idup = dup
dupl_ = dupl
endif
else
idup = 1
dupl_ = psb_dupl_def_
endif
iupdup = ieor(iupdup,idup)
a%infoa(psb_upd_)=iupdup
if (debug) write(0,*)'in ASB',psb_upd_,iupdup
call psb_sp_setifld(upd_,psb_upd_,a,info)
call psb_sp_setifld(dupl_,psb_dupl_,a,info)
a%m = n_row
a%k = n_col
@ -170,39 +151,13 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
goto 9999
! convert to user requested format after the temp copy
end if
if (present(afmt)) then
a%fida = afmt
else
a%fida = '???'
endif
!
! work area requested must be fixed to
! No of Grid'd processes and NNZ+2
!
!!$ size_req = max(a%infoa(psb_nnz_),1)+3
!!$ if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!!$ call psb_cest(a%fida, n_row,n_col,size_req,&
!!$ & ia1_size, ia2_size, aspk_size, iup,info)
!!$ write(0,*) 'ESTIMATE : ',ia1_size,ia2_size,aspk_Size,iup
!!$ if (info /= no_err) then
!!$ info=4010
!!$ ch_err='psb_cest'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ 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)
@ -210,7 +165,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
close(iout)
endif
! Do the real conversion into the requested storage formatmode
! Do the real conversion into the requested storage format
! result is put in A
call psb_csdp(atemp,a,info,ifc=2)

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

@ -86,10 +86,12 @@ Subroutine psb_dsprn(a, desc_a,info)
goto 9999
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
if (psb_sp_getifld(psb_upd_,a,info)==psb_upd_perm_) then
if(a%fida(1:3).eq.'JAD') then
a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
else
@ -97,16 +99,17 @@ Subroutine psb_dsprn(a, desc_a,info)
endif
endif
a%infoa(psb_state_) = psb_spmat_upd_
else if (a%infoa(psb_state_) == psb_spmat_bld_) then
case(psb_spmat_bld_)
! in this case do nothing. this allows sprn to be called
! right after allocate, with spins doing the right thing.
! hopefully :-)
else if (a%infoa(psb_state_) == psb_spmat_upd_) then
else
case( psb_spmat_upd_)
case default
info=591
call psb_errpush(info,name)
endif
end select
if (info /= 0) goto 9999

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

@ -45,7 +45,7 @@
! 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.
subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck)
& iblck, jblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@ -60,11 +60,12 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
integer, intent(in) :: blck(:,:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals.....
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
character(len=20) :: name, ch_err
@ -161,7 +162,30 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
else
jblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
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
do col = 1, n
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
@ -177,6 +201,11 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@ -238,7 +267,7 @@ end subroutine psb_iins
! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
& iblck)
& iblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@ -263,11 +292,12 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
integer, intent(in) :: blck(:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,&
& 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
if(psb_get_errstatus().ne.0) return
@ -285,6 +315,29 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
iblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
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
@ -299,6 +352,11 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
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)
return
@ -356,7 +414,7 @@ end subroutine psb_iinsvm
! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
& iblck)
& iblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@ -378,11 +436,12 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(in) :: blck(:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,k,&
& 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
if(psb_get_errstatus().ne.0) return
@ -451,7 +510,30 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
else
iblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
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) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
@ -466,6 +548,11 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
x(loc_row) = x(loc_row) + 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)
return

109
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.
! 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,&
& iblck, jblck)
& iblck, jblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
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(:,:)
integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,err_act,&
& 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(len=20) :: name, char_err
@ -161,7 +162,30 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
else
jblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
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
do col = 1, n
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
@ -177,6 +201,11 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@ -240,7 +269,7 @@ end subroutine psb_zins
! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck)
& iblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
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(:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals.....
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
if(psb_get_errstatus().ne.0) return
@ -351,7 +381,29 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
else
iblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
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
@ -366,6 +418,11 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
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)
return
@ -427,7 +484,7 @@ end subroutine psb_zinsvm
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! insflag - integer(optional). ???
subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag)
& iblck,insflag,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@ -450,11 +507,12 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,&
& 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
if(psb_get_errstatus().ne.0) return
@ -528,7 +586,41 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
else
liflag = psb_upd_glbnum_
end if
if (present(dupl)) then
dupl_ = dupl
else
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
@ -554,6 +646,11 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
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)
return

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

@ -42,7 +42,7 @@
! up - character(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_spmat_type
@ -50,33 +50,25 @@ subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
use psb_const_mod
use psi_mod
use psb_error_mod
use psb_string_mod
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....
type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dup
character, optional, intent(in) :: afmt*5, up
integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5
!....Locals....
integer :: int_err(5)
type(psb_zspmat_type) :: atemp
real(kind(1.d0)) :: real_err(5)
integer :: ia1_size,ia2_size,aspk_size,m,i,err,&
& nprow,npcol,myrow,mycol ,size_req,idup,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j, iupdup
& nprow,npcol,myrow,mycol ,size_req,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j
integer :: upd_, dupl_
integer :: icontxt,temp(2),isize(2),n_row
character :: iup
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err
@ -126,38 +118,27 @@ subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
!
! Second step: handle the local matrix part.
!
iupdup = 0
if (present(up)) then
if(up.eq.'Y') then
iupdup = 4
iup = up
else if (up /= 'N') then
write(0,*)'Wrong value for update input in ASB...'
write(0,*)'Changing to default'
iup = 'N'
if (present(upd)) then
upd_=upd
else
iup = 'N'
endif
else
iup = 'N'
upd_ = psb_upd_dflt_
endif
if (present(dup)) then
if((dup.lt.1).or.(dup.gt.3)) then
if (present(dupl)) then
if((dupl < psb_dupl_ovwrt_).or.(dupl > psb_dupl_err_)) then
write(0,*)'Wrong value for duplicate input in ASB...'
write(0,*)'Changing to default'
idup = 1
dupl_ = psb_dupl_def_
else
idup = dup
dupl_ = dupl
endif
else
idup = 1
dupl_ = psb_dupl_def_
endif
iupdup = ieor(iupdup,idup)
a%infoa(psb_upd_)=iupdup
if (debug) write(0,*)'in ASB',psb_upd_,iupdup
call psb_sp_setifld(upd_,psb_upd_,a,info)
call psb_sp_setifld(dupl_,psb_dupl_,a,info)
a%m = n_row
a%k = n_col
@ -170,39 +151,13 @@ subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
goto 9999
! convert to user requested format after the temp copy
end if
if (present(afmt)) then
a%fida = afmt
else
a%fida = '???'
endif
!
! work area requested must be fixed to
! No of Grid'd processes and NNZ+2
!
!!$ size_req = max(a%infoa(psb_nnz_),1)+3
!!$ if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!!$ call psb_cest(a%fida, n_row,n_col,size_req,&
!!$ & ia1_size, ia2_size, aspk_size, iup,info)
!!$ write(0,*) 'ESTIMATE : ',ia1_size,ia2_size,aspk_Size,iup
!!$ if (info /= no_err) then
!!$ info=4010
!!$ ch_err='psb_cest'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ 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)
@ -210,7 +165,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
close(iout)
endif
! Do the real conversion into the requested storage formatmode
! Do the real conversion into the requested storage format
! result is put in A
call psb_csdp(atemp,a,info,ifc=2)

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

@ -420,7 +420,7 @@ contains
call blacs_barrier(icontxt,'all')
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()
if(info/=0)then
info=4010
@ -437,7 +437,7 @@ contains
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
info=4010
ch_err='psspasb'
@ -780,7 +780,7 @@ contains
call blacs_barrier(icontxt,'all')
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()
if(info/=0)then
info=4010
@ -1203,7 +1203,7 @@ contains
call blacs_barrier(icontxt,'all')
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()
if(info/=0)then
info=4010
@ -1220,7 +1220,7 @@ contains
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
info=4010
ch_err='psspasb'
@ -1563,7 +1563,7 @@ contains
call blacs_barrier(icontxt,'all')
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()
if(info/=0)then
info=4010

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

@ -667,7 +667,7 @@ contains
t1 = mpi_wtime()
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')
tasb = mpi_wtime()-t1
if(info.ne.0) then

Write Preview
Loading…
Cancel
Save