*** empty log message ***
Alfredo Buttari
21 years ago
parent
7051d94726
commit
bea96560d1
@ -1,30 +1,45 @@
|
|||||||
include ../../Make.inc
|
include ../../Make.inc
|
||||||
|
|
||||||
#FCOPT= $(FCOPT)
|
|
||||||
F90_PSDOBJS= dcsdp90.o dcssm90.o dcssm90v.o dfixcoo.o dipcoo2csr.o dipcsr2coo.o\
|
|
||||||
dcsprt90.o dspgtdiag.o dspinfo.o dspgtrow.o dspscal.o imsr.o imsrx.o \
|
|
||||||
dsymbmm90.o dnumbmm90.o drwextd.o dtransp90.o smmp.o dcsmm90.o dcsmv90.o\
|
|
||||||
dcsrws90.o psdneigh.o psbdcoins.o string_impl.o dcsnmi90.o
|
|
||||||
|
|
||||||
|
FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \
|
||||||
|
psb_dcsnmi.o psb_dcsprt.o psb_dcsrws.o psb_dcssm.o psb_dcssv.o \
|
||||||
|
psb_dfixcoo.o psb_dipcoo2csr.o psb_dipcsr2coo.o psb_dneigh.o \
|
||||||
|
psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtrow.o \
|
||||||
|
psb_dspinfo.o psb_dspscal.o psb_dsymbmm.o psb_dtransp.o \
|
||||||
|
string_impl.o
|
||||||
|
|
||||||
LIBDIR= ../../lib
|
|
||||||
INCLUDES=-I$(LIBDIR) -I..
|
|
||||||
LIBNAME=$(LIBDIR)/$(F90LIB)
|
|
||||||
HERE=.
|
|
||||||
|
|
||||||
INCDIRS=-I. -I.. -I$(LIBDIR)
|
INCDIRS = -I ../../lib -I .
|
||||||
|
|
||||||
lib: $(F90_PSDOBJS)
|
lib: auxd cood csrd jadd f77d dpd lib1
|
||||||
ar -cur $(LIBNAME) $(F90_PSDOBJS)
|
|
||||||
ranlib $(LIBNAME)
|
|
||||||
|
|
||||||
#$(F90_PSDOBJS): $(MODS)
|
|
||||||
|
|
||||||
.f.o:
|
lib1: $(FOBJS)
|
||||||
$(F90) $(FCOPT) $(INCDIRS) -c $<
|
|
||||||
|
|
||||||
veryclean: clean
|
|
||||||
/bin/rm -f $(LIBNAME)
|
|
||||||
|
|
||||||
clean:
|
auxd:
|
||||||
/bin/rm -f $(F90_PSDOBJS) $(LOCAL_MODS)
|
(cd aux; make lib)
|
||||||
|
|
||||||
|
cood:
|
||||||
|
(cd coo; make lib)
|
||||||
|
|
||||||
|
csrd:
|
||||||
|
(cd csr; make lib)
|
||||||
|
|
||||||
|
jadd:
|
||||||
|
(cd jad; make lib)
|
||||||
|
|
||||||
|
dpd:
|
||||||
|
(cd dp; make lib)
|
||||||
|
|
||||||
|
f77d:
|
||||||
|
(cd f77; make lib)
|
||||||
|
|
||||||
|
clean:
|
||||||
|
/bin/rm -f $(FOBJS)
|
||||||
|
(cd aux; make clean)
|
||||||
|
(cd coo; make clean)
|
||||||
|
(cd csr; make clean)
|
||||||
|
(cd jad; make clean)
|
||||||
|
(cd dp; make clean)
|
||||||
|
(cd f77; make clean)
|
||||||
|
|||||||
@ -1,250 +1,250 @@
|
|||||||
C Covert matrix from COO format to COO Format
|
c covert matrix from COO format to COO format
|
||||||
C
|
c
|
||||||
SUBROUTINE DCOCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO,
|
subroutine dcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info,
|
||||||
* P1,DESCRN,ARN,IA1N,IA2N,INFON,P2,LARN,LIA1N,
|
* p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n,
|
||||||
* LIA2N,AUX,LAUX,IERROR)
|
* lia2n,aux,laux,ierror)
|
||||||
|
|
||||||
IMPLICIT NONE
|
implicit none
|
||||||
INCLUDE 'sparker.fh'
|
include 'psb_const.fh'
|
||||||
|
|
||||||
C .. Scalar Arguments ..
|
c .. scalar arguments ..
|
||||||
INTEGER LARN, LAUX, LIA1N, LIA2N,
|
integer larn, laux, lia1n, lia2n,
|
||||||
+ M, N, IERROR
|
+ m, n, ierror
|
||||||
CHARACTER TRANS,UNITD
|
character trans,unitd
|
||||||
C .. Array Arguments ..
|
c .. array arguments ..
|
||||||
DOUBLE PRECISION AR(*), ARN(*), D(*)
|
double precision ar(*), arn(*), d(*)
|
||||||
INTEGER AUX(0:LAUX-1)
|
integer aux(0:laux-1)
|
||||||
INTEGER IA1(*), IA2(*), INFO(*), IA1N(*), IA2N(*),
|
integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*),
|
||||||
* INFON(*), P1(*), P2(*)
|
* infon(*), p1(*), p2(*)
|
||||||
CHARACTER DESCRA*11, DESCRN*11
|
character descra*11, descrn*11
|
||||||
C .. Local Scalars ..
|
c .. local scalars ..
|
||||||
INTEGER IPX, IP1, IP2, CHECK_FLAG
|
integer ipx, ip1, ip2, check_flag, err_act
|
||||||
INTEGER NNZ, K, I, J, NZL, IRET
|
integer nnz, k, i, j, nzl, iret
|
||||||
INTEGER ELEM_IN, ELEM_OUT
|
integer elem_in, elem_out
|
||||||
LOGICAL SCALE
|
logical scale
|
||||||
INTEGER MAX_NNZERO
|
integer max_nnzero
|
||||||
logical debug
|
logical debug
|
||||||
parameter (debug=.false.)
|
parameter (debug=.false.)
|
||||||
c .. Local Arrays ..
|
c .. local arrays ..
|
||||||
CHARACTER*20 NAME
|
character*20 name
|
||||||
INTEGER INT_VAL(5)
|
integer int_val(5)
|
||||||
C
|
c
|
||||||
C ...Common variables...
|
c ...common variables...
|
||||||
C This flag describe the action to do
|
c this flag describe the action to do
|
||||||
|
|
||||||
C .. External Subroutines ..
|
c .. external subroutines ..
|
||||||
EXTERNAL MAX_NNZERO
|
external max_nnzero
|
||||||
C .. Executable Statements ..
|
c .. executable statements ..
|
||||||
C
|
c
|
||||||
|
|
||||||
NAME = 'DCOCO\0'
|
name = 'dcoco\0'
|
||||||
IERROR = 0
|
ierror = 0
|
||||||
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
|
call fcpsb_erractionsave(err_act)
|
||||||
|
|
||||||
CHECK_FLAG=IBITS(info(upd_),1,2)
|
check_flag=ibits(info(psb_upd_),1,2)
|
||||||
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(nnz_)
|
nnz = info(psb_nnz_)
|
||||||
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
|
||||||
endif
|
endif
|
||||||
IF (LAUX.LT.NNZ+2) THEN
|
if (laux.lt.nnz+2) then
|
||||||
IERROR = 60
|
ierror = 60
|
||||||
INT_VAL(1) = 22
|
int_val(1) = 22
|
||||||
INT_VAL(2) = NNZ+2
|
int_val(2) = nnz+2
|
||||||
INT_VAL(3) = LAUX
|
int_val(3) = laux
|
||||||
ELSE IF (LARN.LT.NNZ) THEN
|
else if (larn.lt.nnz) then
|
||||||
IERROR = 60
|
ierror = 60
|
||||||
INT_VAL(1) = 18
|
int_val(1) = 18
|
||||||
INT_VAL(2) = NNZ+2
|
int_val(2) = nnz+2
|
||||||
INT_VAL(3) = LAUX
|
int_val(3) = laux
|
||||||
ELSE IF (LIA1N.LT.NNZ) THEN
|
else if (lia1n.lt.nnz) then
|
||||||
IERROR = 60
|
ierror = 60
|
||||||
INT_VAL(1) = 19
|
int_val(1) = 19
|
||||||
INT_VAL(2) = NNZ+2
|
int_val(2) = nnz+2
|
||||||
INT_VAL(3) = LAUX
|
int_val(3) = laux
|
||||||
ELSE IF (LIA2N.LT.M+1) THEN
|
else if (lia2n.lt.m+1) then
|
||||||
IERROR = 60
|
ierror = 60
|
||||||
INT_VAL(1) = 20
|
int_val(1) = 20
|
||||||
INT_VAL(2) = NNZ+2
|
int_val(2) = nnz+2
|
||||||
INT_VAL(3) = LAUX
|
int_val(3) = laux
|
||||||
ENDIF
|
endif
|
||||||
|
|
||||||
C
|
c
|
||||||
C Error handling
|
c error handling
|
||||||
C
|
c
|
||||||
IF(IERROR.NE.0) THEN
|
if(ierror.ne.0) then
|
||||||
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
|
call fcpsb_errpush(ierror,name,int_val)
|
||||||
GOTO 9999
|
goto 9999
|
||||||
END IF
|
end if
|
||||||
|
|
||||||
IF (DESCRA(1:1).EQ.'G') THEN
|
if (descra(1:1).eq.'G') then
|
||||||
C
|
c
|
||||||
C Sort COO data structure
|
c sort COO data structure
|
||||||
C
|
c
|
||||||
if (debug) write(*,*)'First sort',nnz
|
if (debug) write(*,*)'first sort',nnz
|
||||||
do k=1, nnz
|
do k=1, nnz
|
||||||
arn(k) = ar(k)
|
arn(k) = ar(k)
|
||||||
ia1n(k) = ia1(k)
|
ia1n(k) = ia1(k)
|
||||||
ia2n(k) = ia2(k)
|
ia2n(k) = ia2(k)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
if (debug) write(*,*)'Second sort'
|
if (debug) write(*,*)'second sort'
|
||||||
|
|
||||||
if ((lia2n.ge.(2*nnz+ireg_flgs+1))
|
if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1))
|
||||||
+ .and.(laux.ge.2*(2+nnz))) then
|
+ .and.(laux.ge.2*(2+nnz))) then
|
||||||
C
|
c
|
||||||
C Prepare for smart regeneration
|
c prepare for smart regeneration
|
||||||
c
|
c
|
||||||
ipx = nnz+3
|
ipx = nnz+3
|
||||||
do i=1, nnz
|
do i=1, nnz
|
||||||
aux(ipx+i-1) = i
|
aux(ipx+i-1) = i
|
||||||
enddo
|
enddo
|
||||||
ip1 = nnz+2
|
ip1 = nnz+2
|
||||||
infon(upd_pnt_) = ip1
|
infon(psb_upd_pnt_) = ip1
|
||||||
ip2 = ip1+ireg_flgs
|
ip2 = ip1+psb_ireg_flgs_
|
||||||
ia2n(ip1+ip2_) = ip2
|
ia2n(ip1+psb_ip2_) = ip2
|
||||||
ia2n(ip1+iflag_) = check_flag
|
ia2n(ip1+psb_iflag_) = check_flag
|
||||||
ia2n(ip1+nnzt_) = nnz
|
ia2n(ip1+psb_nnzt_) = nnz
|
||||||
ia2n(ip1+nnz_) = 0
|
ia2n(ip1+psb_nnz_) = 0
|
||||||
ia2n(ip1+ichk_) = nnz+check_flag
|
ia2n(ip1+psb_ichk_) = nnz+check_flag
|
||||||
if (debug) write(0,*) 'Build check :',ia2n(ip1+nnzt_)
|
if (debug) write(0,*) 'build check :',ia2n(ip1+psb_nnzt_)
|
||||||
|
|
||||||
C .... Order with key IA1N ...
|
c .... order with key ia1n ...
|
||||||
CALL MRGSRT(NNZ,IA1N,AUX,IRET)
|
call mrgsrt(nnz,ia1n,aux,iret)
|
||||||
IF (IRET.EQ.0) CALL REORDVN3(NNZ,ARN,IA1N,IA2N,AUX(IPX),AUX)
|
if (iret.eq.0) call reordvn3(nnz,arn,ia1n,ia2n,aux(ipx),aux)
|
||||||
C .... Order with key IA2N ...
|
c .... order with key ia2n ...
|
||||||
|
|
||||||
I = 1
|
i = 1
|
||||||
J = I
|
j = i
|
||||||
DO WHILE (I.LE.NNZ)
|
do while (i.le.nnz)
|
||||||
DO WHILE ((IA1N(J).EQ.IA1N(I)).AND.
|
do while ((ia1n(j).eq.ia1n(i)).and.
|
||||||
+ (J.LE.NNZ))
|
+ (j.le.nnz))
|
||||||
J = J+1
|
j = j+1
|
||||||
ENDDO
|
enddo
|
||||||
NZL = J - I
|
nzl = j - i
|
||||||
CALL MRGSRT(NZL,IA2N(I),AUX,IRET)
|
call mrgsrt(nzl,ia2n(i),aux,iret)
|
||||||
IF (IRET.EQ.0) CALL REORDVN3(NZL,ARN(I),IA1N(I),IA2N(I),
|
if (iret.eq.0) call reordvn3(nzl,arn(i),ia1n(i),ia2n(i),
|
||||||
+ AUX(IPX+I-1),AUX)
|
+ aux(ipx+i-1),aux)
|
||||||
I = J
|
i = j
|
||||||
ENDDO
|
enddo
|
||||||
|
|
||||||
ia2n(ip2+aux(ipx+1-1)-1) = 1
|
ia2n(ip2+aux(ipx+1-1)-1) = 1
|
||||||
|
|
||||||
C ... Construct final COO Representation...
|
c ... construct final COO representation...
|
||||||
ELEM_OUT = 1
|
elem_out = 1
|
||||||
C ... Insert remaining element ...
|
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.1) 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.2) 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.3) 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
|
||||||
END IF
|
end if
|
||||||
ELSE
|
else
|
||||||
ELEM_OUT = ELEM_OUT + 1
|
elem_out = elem_out + 1
|
||||||
ARN(ELEM_OUT) = ARN(ELEM_IN)
|
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
|
||||||
IA1N(ELEM_OUT) = IA1N(ELEM_IN)
|
ia1n(elem_out) = ia1n(elem_in)
|
||||||
IA2N(ELEM_OUT) = IA2N(ELEM_IN)
|
ia2n(elem_out) = ia2n(elem_in)
|
||||||
ENDIF
|
endif
|
||||||
ENDDO
|
enddo
|
||||||
|
|
||||||
ELSE
|
else
|
||||||
|
|
||||||
C .... Order with key IA1N ...
|
c .... order with key ia1n ...
|
||||||
CALL MRGSRT(NNZ,IA1N,AUX,IRET)
|
call mrgsrt(nnz,ia1n,aux,iret)
|
||||||
IF (IRET.EQ.0) CALL REORDVN(NNZ,ARN,IA1N,IA2N,AUX)
|
if (iret.eq.0) call reordvn(nnz,arn,ia1n,ia2n,aux)
|
||||||
C .... Order with key IA2N ...
|
c .... order with key ia2n ...
|
||||||
|
|
||||||
I = 1
|
i = 1
|
||||||
J = I
|
j = i
|
||||||
DO WHILE (I.LE.NNZ)
|
do while (i.le.nnz)
|
||||||
DO WHILE ((IA1N(J).EQ.IA1N(I)).AND.
|
do while ((ia1n(j).eq.ia1n(i)).and.
|
||||||
+ (J.LE.NNZ))
|
+ (j.le.nnz))
|
||||||
J = J+1
|
j = j+1
|
||||||
ENDDO
|
enddo
|
||||||
NZL = J - I
|
nzl = j - i
|
||||||
CALL MRGSRT(NZL,IA2N(I),AUX,IRET)
|
call mrgsrt(nzl,ia2n(i),aux,iret)
|
||||||
IF (IRET.EQ.0) CALL REORDVN(NZL,ARN(I),IA1N(I),IA2N(I),
|
if (iret.eq.0) call reordvn(nzl,arn(i),ia1n(i),ia2n(i),
|
||||||
+ AUX)
|
+ aux)
|
||||||
I = J
|
i = j
|
||||||
ENDDO
|
enddo
|
||||||
C ... Construct final COO Representation...
|
c ... construct final COO representation...
|
||||||
ELEM_OUT = 1
|
elem_out = 1
|
||||||
C ... Insert remaining element ...
|
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.1) 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.2) 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.3) 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
|
||||||
ELSE
|
else
|
||||||
ELEM_OUT = ELEM_OUT + 1
|
elem_out = elem_out + 1
|
||||||
ARN(ELEM_OUT) = ARN(ELEM_IN)
|
arn(elem_out) = arn(elem_in)
|
||||||
IA1N(ELEM_OUT) = IA1N(ELEM_IN)
|
ia1n(elem_out) = ia1n(elem_in)
|
||||||
IA2N(ELEM_OUT) = IA2N(ELEM_IN)
|
ia2n(elem_out) = ia2n(elem_in)
|
||||||
ENDIF
|
endif
|
||||||
ENDDO
|
enddo
|
||||||
ENDIF
|
endif
|
||||||
INFON(nnz_) = ELEM_OUT
|
infon(psb_nnz_) = elem_out
|
||||||
infon(srtd_) = isrtdcoo
|
infon(psb_srtd_) = psb_isrtdcoo_
|
||||||
|
|
||||||
if (debug) write(*,*)'Done Rebuild COO',infon(1)
|
if (debug) write(*,*)'done rebuild COO',infon(1)
|
||||||
|
|
||||||
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
|
else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then
|
||||||
|
|
||||||
DO 20 K = 1, M
|
do 20 k = 1, m
|
||||||
P2(K) = K
|
p2(k) = k
|
||||||
20 CONTINUE
|
20 continue
|
||||||
|
|
||||||
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
|
else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then
|
||||||
|
|
||||||
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
|
else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then
|
||||||
|
|
||||||
END IF
|
end if
|
||||||
C
|
c
|
||||||
ELSE IF (TRANS.NE.'N') THEN
|
else if (trans.ne.'N') then
|
||||||
C
|
c
|
||||||
C TO DO
|
c to do
|
||||||
C
|
c
|
||||||
IERROR = 3021
|
ierror = 3021
|
||||||
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
|
call fcpsb_errpush(ierror,name,int_val)
|
||||||
GOTO 9999
|
goto 9999
|
||||||
|
|
||||||
END IF
|
end if
|
||||||
|
|
||||||
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
|
call fcpsb_erractionrestore(err_act)
|
||||||
RETURN
|
return
|
||||||
|
|
||||||
9999 CONTINUE
|
9999 continue
|
||||||
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
|
call fcpsb_erractionrestore(err_act)
|
||||||
|
|
||||||
IF ( ERR_ACT .NE. 0 ) THEN
|
if ( err_act .ne. 0 ) then
|
||||||
CALL FCPSB_SERROR()
|
call fcpsb_serror()
|
||||||
RETURN
|
return
|
||||||
ENDIF
|
endif
|
||||||
|
|
||||||
RETURN
|
return
|
||||||
END
|
end
|
||||||
|
|||||||
@ -0,0 +1,221 @@
|
|||||||
|
! File: psbdcoins.f90
|
||||||
|
! Subroutine:
|
||||||
|
! Parameters:
|
||||||
|
subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
|
||||||
|
|
||||||
|
use psb_spmat_type
|
||||||
|
use psb_const_mod
|
||||||
|
use psb_realloc_mod
|
||||||
|
use psb_string_mod
|
||||||
|
use psb_error_mod
|
||||||
|
use psb_serial_mod, only : psb_spinfo
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: nz, imin,imax,jmin,jmax
|
||||||
|
integer, intent(in) :: ia(:),ja(:),gtl(:)
|
||||||
|
real(kind(1.d0)), intent(in) :: val(:)
|
||||||
|
type(psb_dspmat_type), intent(inout) :: a
|
||||||
|
integer, intent(out) :: 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.
|
||||||
|
character(len=20) :: name, ch_err
|
||||||
|
|
||||||
|
name='psb_dcoins'
|
||||||
|
info = 0
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
if (nz <= 0) then
|
||||||
|
info = 10
|
||||||
|
int_err(1)=1
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(ia) < nz) then
|
||||||
|
info = 35
|
||||||
|
int_err(1)=2
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (size(ja) < nz) then
|
||||||
|
info = 35
|
||||||
|
int_err(1)=3
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(val) < nz) then
|
||||||
|
info = 35
|
||||||
|
int_err(1)=4
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
!!$ ufida = toupper(a%fida)
|
||||||
|
call touppers(a%fida,ufida)
|
||||||
|
ng = size(gtl)
|
||||||
|
spstate = a%infoa(psb_state_)
|
||||||
|
|
||||||
|
select case(spstate)
|
||||||
|
case(psb_spmat_bld_)
|
||||||
|
if ((ufida /= 'COO').and.(ufida/='COI')) then
|
||||||
|
info = 134
|
||||||
|
ch_err(1:3)=ufida(1:3)
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
call psb_spinfo(psb_nztotreq_,a,nza,info)
|
||||||
|
call psb_spinfo(psb_nzsizereq_,a,isza,info)
|
||||||
|
if(info.ne.izero) then
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_spinfo'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
|
||||||
|
if ((nza+nz)>isza) then
|
||||||
|
call psb_spreall(a,nza+nz,info)
|
||||||
|
if(info.ne.izero) then
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_spreall'
|
||||||
|
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
|
||||||
|
ch_err='psb_inner_ins'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
if (debug) then
|
||||||
|
if ((nza - a%infoa(psb_nnz_)) /= nz) then
|
||||||
|
write(0,*) 'PSB_COINS: insert discarded items '
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
if ((nza - a%infoa(psb_nnz_)) /= nz) then
|
||||||
|
a%infoa(psb_del_bnd_) = nza
|
||||||
|
endif
|
||||||
|
a%infoa(psb_nnz_) = nza
|
||||||
|
|
||||||
|
case(psb_spmat_upd_)
|
||||||
|
|
||||||
|
if (ibits(a%infoa(psb_upd_),2,1).eq.1) then
|
||||||
|
ip1 = a%infoa(psb_upd_pnt_)
|
||||||
|
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'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
!!$ if (debug) then
|
||||||
|
!!$ if ((nza - a%ia2(ip1+nnz_)) /= nz) then
|
||||||
|
!!$ write(0,*) 'PSB_COINS: update discarded items '
|
||||||
|
!!$ end if
|
||||||
|
!!$ end if
|
||||||
|
|
||||||
|
a%ia2(ip1+psb_nnz_) = nza
|
||||||
|
else
|
||||||
|
info = 2231
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
|
||||||
|
case default
|
||||||
|
info = 2232
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
return
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act.eq.act_abort) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
contains
|
||||||
|
subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,gtl,imin,imax,jmin,jmax,nzl,info)
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
|
||||||
|
integer, intent(in) :: ia(*),ja(*),gtl(*)
|
||||||
|
integer, intent(inout) :: nza
|
||||||
|
real(kind(1.d0)), intent(in) :: val(*)
|
||||||
|
real(kind(1.d0)), intent(inout) :: aspk(*)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
integer :: i,ir,ic
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (nza >= nzl) then
|
||||||
|
do i=1, nz
|
||||||
|
nza = nza + 1
|
||||||
|
a%aspk(nza) = val(i)
|
||||||
|
end do
|
||||||
|
else
|
||||||
|
do i=1, nz
|
||||||
|
ir = ia(i)
|
||||||
|
ic = ja(i)
|
||||||
|
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
|
||||||
|
ir = gtl(ir)
|
||||||
|
ic = gtl(ic)
|
||||||
|
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
|
||||||
|
nza = nza + 1
|
||||||
|
a%aspk(nza) = val(i)
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
|
||||||
|
end subroutine psb_inner_upd
|
||||||
|
|
||||||
|
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,gtl,&
|
||||||
|
& imin,imax,jmin,jmax,info)
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: nz, imin,imax,jmin,jmax
|
||||||
|
integer, intent(in) :: ia(*),ja(*),gtl(*)
|
||||||
|
integer, intent(inout) :: nza,ia1(*),ia2(*)
|
||||||
|
real(kind(1.d0)), intent(in) :: val(*)
|
||||||
|
real(kind(1.d0)), intent(inout) :: aspk(*)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
integer :: i,ir,ic
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
do i=1, nz
|
||||||
|
ir = ia(i)
|
||||||
|
ic = ja(i)
|
||||||
|
|
||||||
|
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
|
||||||
|
ir = gtl(ir)
|
||||||
|
ic = gtl(ic)
|
||||||
|
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
|
||||||
|
nza = nza + 1
|
||||||
|
a%ia1(nza) = ir
|
||||||
|
a%ia2(nza) = ic
|
||||||
|
a%aspk(nza) = val(i)
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
|
||||||
|
end subroutine psb_inner_ins
|
||||||
|
end subroutine psb_dcoins
|
||||||
|
|
||||||
Loading…
Reference in New Issue