|
|
|
|
C
|
|
|
|
|
C Parallel Sparse BLAS v2.0
|
|
|
|
|
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
|
|
|
|
|
C Alfredo Buttari University of Rome Tor Vergata
|
|
|
|
|
C
|
|
|
|
|
C Redistribution and use in source and binary forms, with or without
|
|
|
|
|
C modification, are permitted provided that the following conditions
|
|
|
|
|
C are met:
|
|
|
|
|
C 1. Redistributions of source code must retain the above copyright
|
|
|
|
|
C notice, this list of conditions and the following disclaimer.
|
|
|
|
|
C 2. Redistributions in binary form must reproduce the above copyright
|
|
|
|
|
C notice, this list of conditions, and the following disclaimer in the
|
|
|
|
|
C documentation and/or other materials provided with the distribution.
|
|
|
|
|
C 3. The name of the PSBLAS group or the names of its contributors may
|
|
|
|
|
C not be used to endorse or promote products derived from this
|
|
|
|
|
C software without specific written permission.
|
|
|
|
|
C
|
|
|
|
|
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
|
|
|
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
|
|
|
|
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
|
|
|
|
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
|
|
|
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
|
|
|
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
|
|
|
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
|
|
|
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
|
|
|
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
|
|
|
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
|
|
|
C POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
|
C
|
|
|
|
|
C
|
|
|
|
|
C Covert matrix from COO format to CSR Format
|
|
|
|
|
C Note: this never sets IP1 and P2!
|
|
|
|
|
C
|
|
|
|
|
SUBROUTINE ZCOCR(TRANS,M,N,UNITD,D,DESCRA,AR,JA,IA,INFO,
|
|
|
|
|
* P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1,
|
|
|
|
|
* LIAN2,AUX,LAUX,IERROR)
|
|
|
|
|
|
|
|
|
|
use psb_const_mod
|
|
|
|
|
use psb_spmat_type
|
|
|
|
|
IMPLICIT NONE
|
|
|
|
|
|
|
|
|
|
C
|
|
|
|
|
C .. Scalar Arguments ..
|
|
|
|
|
INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M,
|
|
|
|
|
+ N, IUPDUP, IERROR
|
|
|
|
|
CHARACTER TRANS,UNITD
|
|
|
|
|
C .. Array Arguments ..
|
|
|
|
|
complex(kind(1.d0)) AR(*), ARN(*), D(*)
|
|
|
|
|
INTEGER AUX(0:LAUX-1)
|
|
|
|
|
INTEGER JA(*), IA(*), INFO(*), IAN1(*), IAN2(*),
|
|
|
|
|
* INFON(*), P1(*), P2(*)
|
|
|
|
|
CHARACTER DESCRA*11, DESCRN*11
|
|
|
|
|
C .. Local Scalars ..
|
|
|
|
|
INTEGER NNZ, K, ROW, I, J, NZL, IRET
|
|
|
|
|
integer ipx, ip1, ip2, CHECK_FLAG, err_act
|
|
|
|
|
INTEGER ELEM, ELEM_CSR
|
|
|
|
|
LOGICAL SCALE
|
|
|
|
|
INTEGER MAX_NNZERO
|
|
|
|
|
logical debug
|
|
|
|
|
parameter (debug=.false.)
|
|
|
|
|
c .. Local Arrays ..
|
|
|
|
|
CHARACTER*20 NAME
|
|
|
|
|
INTEGER INT_VAL(5)
|
|
|
|
|
|
|
|
|
|
C
|
|
|
|
|
C ...Common variables...
|
|
|
|
|
|
|
|
|
|
C .. External Subroutines ..
|
|
|
|
|
EXTERNAL MAX_NNZERO
|
|
|
|
|
C .. Executable Statements ..
|
|
|
|
|
C
|
|
|
|
|
|
|
|
|
|
NAME = 'ZCOCR\0'
|
|
|
|
|
IERROR = 0
|
|
|
|
|
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
|
|
|
|
|
|
|
|
|
|
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
|
|
|
|
|
|
|
|
|
|
IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN
|
|
|
|
|
|
|
|
|
|
SCALE = (UNITD.EQ.'L') ! meaningless
|
|
|
|
|
P1(1) = 0
|
|
|
|
|
P2(1) = 0
|
|
|
|
|
|
|
|
|
|
NNZ = INFO(1)
|
|
|
|
|
if (debug) then
|
|
|
|
|
write(0,*) 'On entry to ZCOCR: NNZ LAUX ',
|
|
|
|
|
+ nnz,laux,larn,lian1,lian2
|
|
|
|
|
endif
|
|
|
|
|
IF (LAUX.LT.NNZ+2) THEN
|
|
|
|
|
IERROR = 60
|
|
|
|
|
INT_VAL(1) = 22
|
|
|
|
|
INT_VAL(2) = NNZ+2
|
|
|
|
|
INT_VAL(3) = LAUX
|
|
|
|
|
ELSE IF (LARN.LT.NNZ) THEN
|
|
|
|
|
IERROR = 60
|
|
|
|
|
INT_VAL(1) = 18
|
|
|
|
|
INT_VAL(2) = NNZ+2
|
|
|
|
|
INT_VAL(3) = LAUX
|
|
|
|
|
ELSE IF (LIAN1.LT.NNZ) THEN
|
|
|
|
|
IERROR = 60
|
|
|
|
|
INT_VAL(1) = 19
|
|
|
|
|
INT_VAL(2) = NNZ+2
|
|
|
|
|
INT_VAL(3) = LAUX
|
|
|
|
|
ELSE IF (LIAN2.LT.M+1) THEN
|
|
|
|
|
IERROR = 60
|
|
|
|
|
INT_VAL(1) = 20
|
|
|
|
|
INT_VAL(2) = NNZ+2
|
|
|
|
|
INT_VAL(3) = LAUX
|
|
|
|
|
ENDIF
|
|
|
|
|
|
|
|
|
|
C
|
|
|
|
|
C Error handling
|
|
|
|
|
C
|
|
|
|
|
IF(IERROR.NE.0) THEN
|
|
|
|
|
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
|
|
|
|
|
GOTO 9999
|
|
|
|
|
END IF
|
|
|
|
|
|
|
|
|
|
IF (DESCRA(1:1).EQ.'G') THEN
|
|
|
|
|
C
|
|
|
|
|
C Sort COO data structure
|
|
|
|
|
C
|
|
|
|
|
if (debug) write(0,*)'First sort',nnz
|
|
|
|
|
c$$$ if (debug) then
|
|
|
|
|
c$$$ do k=1,nnz
|
|
|
|
|
c$$$ write(*,*) k,ia(k),ja(k),ar(k)
|
|
|
|
|
c$$$ enddo
|
|
|
|
|
c$$$ endif
|
|
|
|
|
c$$$ write(0,*) 'ZCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1),
|
|
|
|
|
c$$$ + m+1,nnz,psb_ireg_flgs_,
|
|
|
|
|
c$$$ + laux,2*(2+nnz)
|
|
|
|
|
if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
|
|
|
|
|
+ .and.(laux.ge.2*(2+nnz))) then
|
|
|
|
|
C
|
|
|
|
|
C Prepare for smart regeneration
|
|
|
|
|
c
|
|
|
|
|
|
|
|
|
|
ipx = nnz+3
|
|
|
|
|
do i=1, nnz
|
|
|
|
|
aux(ipx+i-1) = i
|
|
|
|
|
enddo
|
|
|
|
|
ip1 = m+2
|
|
|
|
|
infon(psb_upd_pnt_) = ip1
|
|
|
|
|
ip2 = ip1+psb_ireg_flgs_
|
|
|
|
|
ian2(ip1+psb_ip2_) = ip2
|
|
|
|
|
ian2(ip1+psb_iflag_) = check_flag
|
|
|
|
|
ian2(ip1+psb_nnzt_) = nnz
|
|
|
|
|
ian2(ip1+psb_nnz_) = 0
|
|
|
|
|
ian2(ip1+psb_ichk_) = nnz+check_flag
|
|
|
|
|
|
|
|
|
|
c$$$ write(0,*)'ZCOCR Check: ',ip2,ian2(ip1+psb_iflag_),
|
|
|
|
|
c$$$ + ian2(ip1+psb_nnzt_), ian2(ip1+psb_nnz_),
|
|
|
|
|
c$$$ + ian2(ip1+psb_ichk_)
|
|
|
|
|
|
|
|
|
|
c$$$ + ip1,ip2,nnz,ian2(ip1+nnzt_)
|
|
|
|
|
|
|
|
|
|
if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_)
|
|
|
|
|
C .... Order with key IA ...
|
|
|
|
|
CALL MSORT_UP(NNZ,IA,AUX,IRET)
|
|
|
|
|
IF (IRET.EQ.0) CALL ZREORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX)
|
|
|
|
|
if (debug) then
|
|
|
|
|
do i=1, nnz-1
|
|
|
|
|
if (ia(i).gt.ia(i+1)) then
|
|
|
|
|
write(0,*) 'Sorting error:',i,ia(i),ia(i+1)
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
write(0,*) 'nnz :',m,nnz,ia(nnz),ja(nnz)
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
C .... Order with key IA2N ...
|
|
|
|
|
|
|
|
|
|
I = 1
|
|
|
|
|
J = I
|
|
|
|
|
c$$$ DO WHILE (I.LE.NNZ)
|
|
|
|
|
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
|
|
|
|
|
c$$$ + (J.LE.NNZ))
|
|
|
|
|
DO
|
|
|
|
|
if (I>NNZ) exit
|
|
|
|
|
DO
|
|
|
|
|
if (j>nnz) exit
|
|
|
|
|
if (ia(j) /= ia(i)) exit
|
|
|
|
|
J = J+1
|
|
|
|
|
ENDDO
|
|
|
|
|
NZL = J - I
|
|
|
|
|
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
|
|
|
|
|
IF (IRET.EQ.0) CALL ZREORDVN3(NZL,AR(I),IA(I),JA(I),
|
|
|
|
|
+ AUX(IPX+I-1),AUX)
|
|
|
|
|
I = J
|
|
|
|
|
ENDDO
|
|
|
|
|
|
|
|
|
|
C ... Construct CSR Representation...
|
|
|
|
|
ELEM = 1
|
|
|
|
|
ELEM_CSR = 1
|
|
|
|
|
C ... Insert first element ...
|
|
|
|
|
DO ROW = 1, IA(1)
|
|
|
|
|
IAN2(ROW) = 1
|
|
|
|
|
ENDDO
|
|
|
|
|
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
|
|
|
|
|
ELEM = ELEM+1
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
C ... Insert remaining element ...
|
|
|
|
|
DO ROW = IA(1), M
|
|
|
|
|
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
|
|
|
|
|
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
|
|
|
|
|
DO
|
|
|
|
|
if (elem > nnz) exit
|
|
|
|
|
if (ia(elem) /= row) exit
|
|
|
|
|
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
|
|
|
|
|
C ... Insert first element of a row ...
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
|
|
|
|
|
C ... Insert other element of row ...
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ELSE
|
|
|
|
|
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.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.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
|
|
|
|
|
END IF
|
|
|
|
|
ENDIF
|
|
|
|
|
ELEM = ELEM + 1
|
|
|
|
|
ENDDO
|
|
|
|
|
IAN2(ROW+1) = ELEM_CSR
|
|
|
|
|
ENDDO
|
|
|
|
|
ELSE
|
|
|
|
|
c$$$ write(0,*) 'Going for ELSE !!!?'
|
|
|
|
|
C .... Order with key IA ...
|
|
|
|
|
CALL MSORT_UP(NNZ,IA,AUX,IRET)
|
|
|
|
|
IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
|
|
|
|
|
C .... Order with key IA2N ...
|
|
|
|
|
I = 1
|
|
|
|
|
J = I
|
|
|
|
|
c$$$ DO WHILE (I.LE.NNZ)
|
|
|
|
|
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
|
|
|
|
|
c$$$ + (J.LE.NNZ))
|
|
|
|
|
DO
|
|
|
|
|
if (I>NNZ) exit
|
|
|
|
|
DO
|
|
|
|
|
if (j>nnz) exit
|
|
|
|
|
if (ia(j) /= ia(i)) exit
|
|
|
|
|
J = J+1
|
|
|
|
|
ENDDO
|
|
|
|
|
NZL = J - I
|
|
|
|
|
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
|
|
|
|
|
IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
|
|
|
|
|
I = J
|
|
|
|
|
ENDDO
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
C ... Construct CSR Representation...
|
|
|
|
|
ELEM = 1
|
|
|
|
|
ELEM_CSR = 1
|
|
|
|
|
C ... Insert first element ...
|
|
|
|
|
DO ROW = 1, IA(1)
|
|
|
|
|
IAN2(ROW) = 1
|
|
|
|
|
ENDDO
|
|
|
|
|
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM = ELEM+1
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
C ... Insert remaining element ...
|
|
|
|
|
DO ROW = IA(1), M
|
|
|
|
|
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
|
|
|
|
|
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
|
|
|
|
|
DO
|
|
|
|
|
if (elem > nnz) exit
|
|
|
|
|
if (ia(elem) /= row) exit
|
|
|
|
|
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
|
|
|
|
|
C ... Insert first element of a row ...
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
|
|
|
|
|
C ... Insert other element of row ...
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ELSE
|
|
|
|
|
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.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.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',
|
|
|
|
|
+ elem_csr-1,elem
|
|
|
|
|
END IF
|
|
|
|
|
ENDIF
|
|
|
|
|
ELEM = ELEM + 1
|
|
|
|
|
ENDDO
|
|
|
|
|
IAN2(ROW+1) = ELEM_CSR
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDIF
|
|
|
|
|
|
|
|
|
|
if (debug) write(0,*)'Done Rebuild CSR',
|
|
|
|
|
+ ian2(m+1),ia(elem)
|
|
|
|
|
if (debug) then
|
|
|
|
|
do i=ian2(m+1), nnz
|
|
|
|
|
write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
|
|
|
|
|
enddo
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
|
|
|
|
|
|
|
|
|
|
DO 20 K = 1, M
|
|
|
|
|
P2(K) = K
|
|
|
|
|
20 CONTINUE
|
|
|
|
|
|
|
|
|
|
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
|
|
|
|
|
|
|
|
|
|
C .... Order with key IA ...
|
|
|
|
|
CALL MSORT_UP(NNZ,IA,AUX,IRET)
|
|
|
|
|
IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
|
|
|
|
|
C .... Order with key IA2N ...
|
|
|
|
|
I = 1
|
|
|
|
|
J = I
|
|
|
|
|
c$$$ DO WHILE (I.LE.NNZ)
|
|
|
|
|
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
|
|
|
|
|
c$$$ + (J.LE.NNZ))
|
|
|
|
|
DO
|
|
|
|
|
if (I>NNZ) exit
|
|
|
|
|
DO
|
|
|
|
|
if (j>nnz) exit
|
|
|
|
|
if (ia(j) /= ia(i)) exit
|
|
|
|
|
J = J+1
|
|
|
|
|
ENDDO
|
|
|
|
|
NZL = J - I
|
|
|
|
|
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
|
|
|
|
|
IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
|
|
|
|
|
I = J
|
|
|
|
|
ENDDO
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
C ... Construct CSR Representation...
|
|
|
|
|
ELEM = 1
|
|
|
|
|
ELEM_CSR = 1
|
|
|
|
|
C ... Insert first element ...
|
|
|
|
|
DO ROW = 1, IA(1)
|
|
|
|
|
IAN2(ROW) = 1
|
|
|
|
|
ENDDO
|
|
|
|
|
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
|
|
|
|
|
IF(JA(ELEM).GT.IA(ELEM)) THEN
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ENDIF
|
|
|
|
|
|
|
|
|
|
ELEM = ELEM+1
|
|
|
|
|
|
|
|
|
|
C ... Insert remaining element ...
|
|
|
|
|
DO ROW = IA(1), M
|
|
|
|
|
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
|
|
|
|
|
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
|
|
|
|
|
DO
|
|
|
|
|
if (elem > nnz) exit
|
|
|
|
|
if (ia(elem) /= row) exit
|
|
|
|
|
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
|
|
|
|
|
C ... Insert first element of a row ...
|
|
|
|
|
IF(JA(ELEM).GT.IA(ELEM)) THEN
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ENDIF
|
|
|
|
|
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
|
|
|
|
|
C ... Insert other element of row ...
|
|
|
|
|
IF(JA(ELEM).GT.IA(ELEM)) THEN
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ENDIF
|
|
|
|
|
ELSE
|
|
|
|
|
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.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.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)
|
|
|
|
|
ENDIF
|
|
|
|
|
if (debug) write(0,*) 'Duplicated add',
|
|
|
|
|
+ elem_csr-1,elem
|
|
|
|
|
END IF
|
|
|
|
|
ENDIF
|
|
|
|
|
ELEM = ELEM + 1
|
|
|
|
|
ENDDO
|
|
|
|
|
IAN2(ROW+1) = ELEM_CSR
|
|
|
|
|
ENDDO
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (debug) write(0,*)'Done Rebuild CSR',
|
|
|
|
|
+ ian2(m+1),ia(elem)
|
|
|
|
|
if (debug) then
|
|
|
|
|
do i=ian2(m+1), nnz
|
|
|
|
|
write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
|
|
|
|
|
enddo
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
|
|
|
|
|
|
|
|
|
|
C .... Order with key IA ...
|
|
|
|
|
CALL MSORT_UP(NNZ,IA,AUX,IRET)
|
|
|
|
|
IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
|
|
|
|
|
C .... Order with key IA2N ...
|
|
|
|
|
I = 1
|
|
|
|
|
J = I
|
|
|
|
|
c$$$ DO WHILE (I.LE.NNZ)
|
|
|
|
|
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
|
|
|
|
|
c$$$ + (J.LE.NNZ))
|
|
|
|
|
DO
|
|
|
|
|
if (I>NNZ) exit
|
|
|
|
|
DO
|
|
|
|
|
if (j>nnz) exit
|
|
|
|
|
if (ia(j) /= ia(i)) exit
|
|
|
|
|
J = J+1
|
|
|
|
|
ENDDO
|
|
|
|
|
NZL = J - I
|
|
|
|
|
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
|
|
|
|
|
IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
|
|
|
|
|
I = J
|
|
|
|
|
ENDDO
|
|
|
|
|
|
|
|
|
|
C ... Construct CSR Representation...
|
|
|
|
|
ELEM = 1
|
|
|
|
|
ELEM_CSR = 1
|
|
|
|
|
C ... Insert first element ...
|
|
|
|
|
DO ROW = 1, IA(1)
|
|
|
|
|
IAN2(ROW) = 1
|
|
|
|
|
ENDDO
|
|
|
|
|
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
|
|
|
|
|
IF(JA(ELEM).LT.IA(ELEM)) THEN
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ENDIF
|
|
|
|
|
ELEM = ELEM+1
|
|
|
|
|
|
|
|
|
|
C ... Insert remaining element ...
|
|
|
|
|
DO ROW = IA(1), M
|
|
|
|
|
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
|
|
|
|
|
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
|
|
|
|
|
DO
|
|
|
|
|
if (elem > nnz) exit
|
|
|
|
|
if (ia(elem) /= row) exit
|
|
|
|
|
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
|
|
|
|
|
C ... Insert first element of a row ...
|
|
|
|
|
IF(JA(ELEM).LT.IA(ELEM)) THEN
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ENDIF
|
|
|
|
|
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
|
|
|
|
|
C ... Insert other element of row ...
|
|
|
|
|
IF(JA(ELEM).LT.IA(ELEM)) THEN
|
|
|
|
|
IAN1(ELEM_CSR) = JA(ELEM)
|
|
|
|
|
ARN(ELEM_CSR) = AR(ELEM)
|
|
|
|
|
ELEM_CSR = ELEM_CSR+1
|
|
|
|
|
ENDIF
|
|
|
|
|
ELSE
|
|
|
|
|
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.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.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)
|
|
|
|
|
ENDIF
|
|
|
|
|
if (debug) write(0,*) 'Duplicated add',
|
|
|
|
|
+ elem_csr-1,elem
|
|
|
|
|
END IF
|
|
|
|
|
ENDIF
|
|
|
|
|
ELEM = ELEM + 1
|
|
|
|
|
ENDDO
|
|
|
|
|
IAN2(ROW+1) = ELEM_CSR
|
|
|
|
|
ENDDO
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (debug) write(0,*)'Done Rebuild CSR',
|
|
|
|
|
+ ian2(m+1),ia(elem)
|
|
|
|
|
if (debug) then
|
|
|
|
|
do i=ian2(m+1), nnz
|
|
|
|
|
write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
|
|
|
|
|
enddo
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
END IF
|
|
|
|
|
C
|
|
|
|
|
ELSE IF (TRANS.NE.'N') THEN
|
|
|
|
|
C
|
|
|
|
|
C TO DO
|
|
|
|
|
C
|
|
|
|
|
IERROR = 3021
|
|
|
|
|
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
|
|
|
|
|
GOTO 9999
|
|
|
|
|
|
|
|
|
|
END IF
|
|
|
|
|
INFON(1)=ELEM_CSR-1
|
|
|
|
|
|
|
|
|
|
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
|
|
|
|
|
RETURN
|
|
|
|
|
|
|
|
|
|
9999 CONTINUE
|
|
|
|
|
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
|
|
|
|
|
|
|
|
|
|
IF ( ERR_ACT .NE. 0 ) THEN
|
|
|
|
|
CALL FCPSB_SERROR()
|
|
|
|
|
RETURN
|
|
|
|
|
ENDIF
|
|
|
|
|
|
|
|
|
|
RETURN
|
|
|
|
|
END
|
