mirror of https://gitlab.com/QEF/q-e.git
3830 lines
111 KiB
Fortran
3830 lines
111 KiB
Fortran
SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
|
|
C
|
|
C CONSTANT TIMES A VECTOR PLUS A VECTOR.
|
|
C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
|
|
C JACK DONGARRA, LINPACK, 3/11/78.
|
|
C
|
|
DOUBLE PRECISION DX(1),DY(1),DA
|
|
INTEGER I,INCX,INCY,IX,IY,M,MP1,N
|
|
C
|
|
IF(N.LE.0)RETURN
|
|
IF (DA .EQ. 0.0D0) RETURN
|
|
IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
|
|
C
|
|
C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
|
|
C NOT EQUAL TO 1
|
|
C
|
|
IX = 1
|
|
IY = 1
|
|
IF(INCX.LT.0)IX = (-N+1)*INCX + 1
|
|
IF(INCY.LT.0)IY = (-N+1)*INCY + 1
|
|
DO 10 I = 1,N
|
|
DY(IY) = DY(IY) + DA*DX(IX)
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
10 CONTINUE
|
|
RETURN
|
|
C
|
|
C CODE FOR BOTH INCREMENTS EQUAL TO 1
|
|
C
|
|
C
|
|
C CLEAN-UP LOOP
|
|
C
|
|
20 M = MOD(N,4)
|
|
IF( M .EQ. 0 ) GO TO 40
|
|
DO 30 I = 1,M
|
|
DY(I) = DY(I) + DA*DX(I)
|
|
30 CONTINUE
|
|
IF( N .LT. 4 ) RETURN
|
|
40 MP1 = M + 1
|
|
DO 50 I = MP1,N,4
|
|
DY(I) = DY(I) + DA*DX(I)
|
|
DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
|
|
DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
|
|
DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
|
|
50 CONTINUE
|
|
RETURN
|
|
END
|
|
DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
|
|
C
|
|
C FORMS THE DOT PRODUCT OF TWO VECTORS.
|
|
C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
|
|
C JACK DONGARRA, LINPACK, 3/11/78.
|
|
C
|
|
DOUBLE PRECISION DX(1),DY(1),DTEMP
|
|
INTEGER I,INCX,INCY,IX,IY,M,MP1,N
|
|
C
|
|
DDOT = 0.0D0
|
|
DTEMP = 0.0D0
|
|
IF(N.LE.0)RETURN
|
|
IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
|
|
C
|
|
C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
|
|
C NOT EQUAL TO 1
|
|
C
|
|
IX = 1
|
|
IY = 1
|
|
IF(INCX.LT.0)IX = (-N+1)*INCX + 1
|
|
IF(INCY.LT.0)IY = (-N+1)*INCY + 1
|
|
DO 10 I = 1,N
|
|
DTEMP = DTEMP + DX(IX)*DY(IY)
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
10 CONTINUE
|
|
DDOT = DTEMP
|
|
RETURN
|
|
C
|
|
C CODE FOR BOTH INCREMENTS EQUAL TO 1
|
|
C
|
|
C
|
|
C CLEAN-UP LOOP
|
|
C
|
|
20 M = MOD(N,5)
|
|
IF( M .EQ. 0 ) GO TO 40
|
|
DO 30 I = 1,M
|
|
DTEMP = DTEMP + DX(I)*DY(I)
|
|
30 CONTINUE
|
|
IF( N .LT. 5 ) GO TO 60
|
|
40 MP1 = M + 1
|
|
DO 50 I = MP1,N,5
|
|
DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
|
|
* DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
|
|
50 CONTINUE
|
|
60 DDOT = DTEMP
|
|
RETURN
|
|
END
|
|
SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
|
|
$ BETA, C, LDC )
|
|
* .. SCALAR ARGUMENTS ..
|
|
CHARACTER*1 TRANSA, TRANSB
|
|
INTEGER M, N, K, LDA, LDB, LDC
|
|
DOUBLE PRECISION ALPHA, BETA
|
|
* .. ARRAY ARGUMENTS ..
|
|
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * )
|
|
* ..
|
|
*
|
|
* PURPOSE
|
|
* =======
|
|
*
|
|
* DGEMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS
|
|
*
|
|
* C := ALPHA*OP( A )*OP( B ) + BETA*C,
|
|
*
|
|
* WHERE OP( X ) IS ONE OF
|
|
*
|
|
* OP( X ) = X OR OP( X ) = X',
|
|
*
|
|
* ALPHA AND BETA ARE SCALARS, AND A, B AND C ARE MATRICES, WITH OP( A )
|
|
* AN M BY K MATRIX, OP( B ) A K BY N MATRIX AND C AN M BY N MATRIX.
|
|
*
|
|
* PARAMETERS
|
|
* ==========
|
|
*
|
|
* TRANSA - CHARACTER*1.
|
|
* ON ENTRY, TRANSA SPECIFIES THE FORM OF OP( A ) TO BE USED IN
|
|
* THE MATRIX MULTIPLICATION AS FOLLOWS:
|
|
*
|
|
* TRANSA = 'N' OR 'N', OP( A ) = A.
|
|
*
|
|
* TRANSA = 'T' OR 'T', OP( A ) = A'.
|
|
*
|
|
* TRANSA = 'C' OR 'C', OP( A ) = A'.
|
|
*
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* TRANSB - CHARACTER*1.
|
|
* ON ENTRY, TRANSB SPECIFIES THE FORM OF OP( B ) TO BE USED IN
|
|
* THE MATRIX MULTIPLICATION AS FOLLOWS:
|
|
*
|
|
* TRANSB = 'N' OR 'N', OP( B ) = B.
|
|
*
|
|
* TRANSB = 'T' OR 'T', OP( B ) = B'.
|
|
*
|
|
* TRANSB = 'C' OR 'C', OP( B ) = B'.
|
|
*
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* M - INTEGER.
|
|
* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX
|
|
* OP( A ) AND OF THE MATRIX C. M MUST BE AT LEAST ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* N - INTEGER.
|
|
* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX
|
|
* OP( B ) AND THE NUMBER OF COLUMNS OF THE MATRIX C. N MUST BE
|
|
* AT LEAST ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* K - INTEGER.
|
|
* ON ENTRY, K SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX
|
|
* OP( A ) AND THE NUMBER OF ROWS OF THE MATRIX OP( B ). K MUST
|
|
* BE AT LEAST ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* ALPHA - DOUBLE PRECISION.
|
|
* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, KA ), WHERE KA IS
|
|
* K WHEN TRANSA = 'N' OR 'N', AND IS M OTHERWISE.
|
|
* BEFORE ENTRY WITH TRANSA = 'N' OR 'N', THE LEADING M BY K
|
|
* PART OF THE ARRAY A MUST CONTAIN THE MATRIX A, OTHERWISE
|
|
* THE LEADING K BY M PART OF THE ARRAY A MUST CONTAIN THE
|
|
* MATRIX A.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* LDA - INTEGER.
|
|
* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED
|
|
* IN THE CALLING (SUB) PROGRAM. WHEN TRANSA = 'N' OR 'N' THEN
|
|
* LDA MUST BE AT LEAST MAX( 1, M ), OTHERWISE LDA MUST BE AT
|
|
* LEAST MAX( 1, K ).
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* B - DOUBLE PRECISION ARRAY OF DIMENSION ( LDB, KB ), WHERE KB IS
|
|
* N WHEN TRANSB = 'N' OR 'N', AND IS K OTHERWISE.
|
|
* BEFORE ENTRY WITH TRANSB = 'N' OR 'N', THE LEADING K BY N
|
|
* PART OF THE ARRAY B MUST CONTAIN THE MATRIX B, OTHERWISE
|
|
* THE LEADING N BY K PART OF THE ARRAY B MUST CONTAIN THE
|
|
* MATRIX B.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* LDB - INTEGER.
|
|
* ON ENTRY, LDB SPECIFIES THE FIRST DIMENSION OF B AS DECLARED
|
|
* IN THE CALLING (SUB) PROGRAM. WHEN TRANSB = 'N' OR 'N' THEN
|
|
* LDB MUST BE AT LEAST MAX( 1, K ), OTHERWISE LDB MUST BE AT
|
|
* LEAST MAX( 1, N ).
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* BETA - DOUBLE PRECISION.
|
|
* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS
|
|
* SUPPLIED AS ZERO THEN C NEED NOT BE SET ON INPUT.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* C - DOUBLE PRECISION ARRAY OF DIMENSION ( LDC, N ).
|
|
* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY C MUST
|
|
* CONTAIN THE MATRIX C, EXCEPT WHEN BETA IS ZERO, IN WHICH
|
|
* CASE C NEED NOT BE SET ON ENTRY.
|
|
* ON EXIT, THE ARRAY C IS OVERWRITTEN BY THE M BY N MATRIX
|
|
* ( ALPHA*OP( A )*OP( B ) + BETA*C ).
|
|
*
|
|
* LDC - INTEGER.
|
|
* ON ENTRY, LDC SPECIFIES THE FIRST DIMENSION OF C AS DECLARED
|
|
* IN THE CALLING (SUB) PROGRAM. LDC MUST BE AT LEAST
|
|
* MAX( 1, M ).
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
*
|
|
* LEVEL 3 BLAS ROUTINE.
|
|
*
|
|
* -- WRITTEN ON 8-FEBRUARY-1989.
|
|
* JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
|
|
* IAIN DUFF, AERE HARWELL.
|
|
* JEREMY DU CROZ, NUMERICAL ALGORITHMS GROUP LTD.
|
|
* SVEN HAMMARLING, NUMERICAL ALGORITHMS GROUP LTD.
|
|
*
|
|
*
|
|
* .. EXTERNAL FUNCTIONS ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. EXTERNAL SUBROUTINES ..
|
|
EXTERNAL XERBLA
|
|
* .. INTRINSIC FUNCTIONS ..
|
|
INTRINSIC MAX
|
|
* .. LOCAL SCALARS ..
|
|
LOGICAL NOTA, NOTB
|
|
INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
|
|
DOUBLE PRECISION TEMP
|
|
* .. PARAMETERS ..
|
|
DOUBLE PRECISION ONE , ZERO
|
|
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
|
* ..
|
|
* .. EXECUTABLE STATEMENTS ..
|
|
*
|
|
* SET NOTA AND NOTB AS TRUE IF A AND B RESPECTIVELY ARE NOT
|
|
* TRANSPOSED AND SET NROWA, NCOLA AND NROWB AS THE NUMBER OF ROWS
|
|
* AND COLUMNS OF A AND THE NUMBER OF ROWS OF B RESPECTIVELY.
|
|
*
|
|
NOTA = LSAME( TRANSA, 'N' )
|
|
NOTB = LSAME( TRANSB, 'N' )
|
|
IF( NOTA )THEN
|
|
NROWA = M
|
|
NCOLA = K
|
|
ELSE
|
|
NROWA = K
|
|
NCOLA = M
|
|
END IF
|
|
IF( NOTB )THEN
|
|
NROWB = K
|
|
ELSE
|
|
NROWB = N
|
|
END IF
|
|
*
|
|
* TEST THE INPUT PARAMETERS.
|
|
*
|
|
INFO = 0
|
|
IF( ( .NOT.NOTA ).AND.
|
|
$ ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
|
|
$ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN
|
|
INFO = 1
|
|
ELSE IF( ( .NOT.NOTB ).AND.
|
|
$ ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
|
|
$ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN
|
|
INFO = 2
|
|
ELSE IF( M .LT.0 )THEN
|
|
INFO = 3
|
|
ELSE IF( N .LT.0 )THEN
|
|
INFO = 4
|
|
ELSE IF( K .LT.0 )THEN
|
|
INFO = 5
|
|
ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
|
|
INFO = 8
|
|
ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
|
|
INFO = 10
|
|
ELSE IF( LDC.LT.MAX( 1, M ) )THEN
|
|
INFO = 13
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'DGEMM ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* QUICK RETURN IF POSSIBLE.
|
|
*
|
|
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
|
|
$ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
|
|
$ RETURN
|
|
*
|
|
* AND IF ALPHA.EQ.ZERO.
|
|
*
|
|
IF( ALPHA.EQ.ZERO )THEN
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 20, J = 1, N
|
|
DO 10, I = 1, M
|
|
C( I, J ) = ZERO
|
|
10 CONTINUE
|
|
20 CONTINUE
|
|
ELSE
|
|
DO 40, J = 1, N
|
|
DO 30, I = 1, M
|
|
C( I, J ) = BETA*C( I, J )
|
|
30 CONTINUE
|
|
40 CONTINUE
|
|
END IF
|
|
RETURN
|
|
END IF
|
|
*
|
|
* START THE OPERATIONS.
|
|
*
|
|
IF( NOTB )THEN
|
|
IF( NOTA )THEN
|
|
*
|
|
* FORM C := ALPHA*A*B + BETA*C.
|
|
*
|
|
DO 90, J = 1, N
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 50, I = 1, M
|
|
C( I, J ) = ZERO
|
|
50 CONTINUE
|
|
ELSE IF( BETA.NE.ONE )THEN
|
|
DO 60, I = 1, M
|
|
C( I, J ) = BETA*C( I, J )
|
|
60 CONTINUE
|
|
END IF
|
|
DO 80, L = 1, K
|
|
IF( B( L, J ).NE.ZERO )THEN
|
|
TEMP = ALPHA*B( L, J )
|
|
DO 70, I = 1, M
|
|
C( I, J ) = C( I, J ) + TEMP*A( I, L )
|
|
70 CONTINUE
|
|
END IF
|
|
80 CONTINUE
|
|
90 CONTINUE
|
|
ELSE
|
|
*
|
|
* FORM C := ALPHA*A'*B + BETA*C
|
|
*
|
|
DO 120, J = 1, N
|
|
DO 110, I = 1, M
|
|
TEMP = ZERO
|
|
DO 100, L = 1, K
|
|
TEMP = TEMP + A( L, I )*B( L, J )
|
|
100 CONTINUE
|
|
IF( BETA.EQ.ZERO )THEN
|
|
C( I, J ) = ALPHA*TEMP
|
|
ELSE
|
|
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
|
END IF
|
|
110 CONTINUE
|
|
120 CONTINUE
|
|
END IF
|
|
ELSE
|
|
IF( NOTA )THEN
|
|
*
|
|
* FORM C := ALPHA*A*B' + BETA*C
|
|
*
|
|
DO 170, J = 1, N
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 130, I = 1, M
|
|
C( I, J ) = ZERO
|
|
130 CONTINUE
|
|
ELSE IF( BETA.NE.ONE )THEN
|
|
DO 140, I = 1, M
|
|
C( I, J ) = BETA*C( I, J )
|
|
140 CONTINUE
|
|
END IF
|
|
DO 160, L = 1, K
|
|
IF( B( J, L ).NE.ZERO )THEN
|
|
TEMP = ALPHA*B( J, L )
|
|
DO 150, I = 1, M
|
|
C( I, J ) = C( I, J ) + TEMP*A( I, L )
|
|
150 CONTINUE
|
|
END IF
|
|
160 CONTINUE
|
|
170 CONTINUE
|
|
ELSE
|
|
*
|
|
* FORM C := ALPHA*A'*B' + BETA*C
|
|
*
|
|
DO 200, J = 1, N
|
|
DO 190, I = 1, M
|
|
TEMP = ZERO
|
|
DO 180, L = 1, K
|
|
TEMP = TEMP + A( L, I )*B( J, L )
|
|
180 CONTINUE
|
|
IF( BETA.EQ.ZERO )THEN
|
|
C( I, J ) = ALPHA*TEMP
|
|
ELSE
|
|
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
|
END IF
|
|
190 CONTINUE
|
|
200 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* END OF DGEMM .
|
|
*
|
|
END
|
|
SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
|
|
$ BETA, Y, INCY )
|
|
* .. SCALAR ARGUMENTS ..
|
|
DOUBLE PRECISION ALPHA, BETA
|
|
INTEGER INCX, INCY, LDA, M, N
|
|
CHARACTER*1 TRANS
|
|
* .. ARRAY ARGUMENTS ..
|
|
DOUBLE PRECISION A( LDA, * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* PURPOSE
|
|
* =======
|
|
*
|
|
* DGEMV PERFORMS ONE OF THE MATRIX-VECTOR OPERATIONS
|
|
*
|
|
* Y := ALPHA*A*X + BETA*Y, OR Y := ALPHA*A'*X + BETA*Y,
|
|
*
|
|
* WHERE ALPHA AND BETA ARE SCALARS, X AND Y ARE VECTORS AND A IS AN
|
|
* M BY N MATRIX.
|
|
*
|
|
* PARAMETERS
|
|
* ==========
|
|
*
|
|
* TRANS - CHARACTER*1.
|
|
* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS
|
|
* FOLLOWS:
|
|
*
|
|
* TRANS = 'N' OR 'N' Y := ALPHA*A*X + BETA*Y.
|
|
*
|
|
* TRANS = 'T' OR 'T' Y := ALPHA*A'*X + BETA*Y.
|
|
*
|
|
* TRANS = 'C' OR 'C' Y := ALPHA*A'*X + BETA*Y.
|
|
*
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* M - INTEGER.
|
|
* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX A.
|
|
* M MUST BE AT LEAST ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* N - INTEGER.
|
|
* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX A.
|
|
* N MUST BE AT LEAST ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* ALPHA - DOUBLE PRECISION.
|
|
* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ).
|
|
* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY A MUST
|
|
* CONTAIN THE MATRIX OF COEFFICIENTS.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* LDA - INTEGER.
|
|
* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED
|
|
* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST
|
|
* MAX( 1, M ).
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST
|
|
* ( 1 + ( N - 1 )*ABS( INCX ) ) WHEN TRANS = 'N' OR 'N'
|
|
* AND AT LEAST
|
|
* ( 1 + ( M - 1 )*ABS( INCX ) ) OTHERWISE.
|
|
* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE
|
|
* VECTOR X.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* INCX - INTEGER.
|
|
* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF
|
|
* X. INCX MUST NOT BE ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* BETA - DOUBLE PRECISION.
|
|
* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS
|
|
* SUPPLIED AS ZERO THEN Y NEED NOT BE SET ON INPUT.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST
|
|
* ( 1 + ( M - 1 )*ABS( INCY ) ) WHEN TRANS = 'N' OR 'N'
|
|
* AND AT LEAST
|
|
* ( 1 + ( N - 1 )*ABS( INCY ) ) OTHERWISE.
|
|
* BEFORE ENTRY WITH BETA NON-ZERO, THE INCREMENTED ARRAY Y
|
|
* MUST CONTAIN THE VECTOR Y. ON EXIT, Y IS OVERWRITTEN BY THE
|
|
* UPDATED VECTOR Y.
|
|
*
|
|
* INCY - INTEGER.
|
|
* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF
|
|
* Y. INCY MUST NOT BE ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
*
|
|
* LEVEL 2 BLAS ROUTINE.
|
|
*
|
|
* -- WRITTEN ON 22-OCTOBER-1986.
|
|
* JACK DONGARRA, ARGONNE NATIONAL LAB.
|
|
* JEREMY DU CROZ, NAG CENTRAL OFFICE.
|
|
* SVEN HAMMARLING, NAG CENTRAL OFFICE.
|
|
* RICHARD HANSON, SANDIA NATIONAL LABS.
|
|
*
|
|
*
|
|
* .. PARAMETERS ..
|
|
DOUBLE PRECISION ONE , ZERO
|
|
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
|
* .. LOCAL SCALARS ..
|
|
DOUBLE PRECISION TEMP
|
|
INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
|
|
* .. EXTERNAL FUNCTIONS ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. EXTERNAL SUBROUTINES ..
|
|
EXTERNAL XERBLA
|
|
* .. INTRINSIC FUNCTIONS ..
|
|
INTRINSIC MAX
|
|
* ..
|
|
* .. EXECUTABLE STATEMENTS ..
|
|
*
|
|
* TEST THE INPUT PARAMETERS.
|
|
*
|
|
INFO = 0
|
|
IF ( .NOT.LSAME( TRANS, 'N' ).AND.
|
|
$ .NOT.LSAME( TRANS, 'T' ).AND.
|
|
$ .NOT.LSAME( TRANS, 'C' ) )THEN
|
|
INFO = 1
|
|
ELSE IF( M.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 3
|
|
ELSE IF( LDA.LT.MAX( 1, M ) )THEN
|
|
INFO = 6
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 8
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 11
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'DGEMV ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* QUICK RETURN IF POSSIBLE.
|
|
*
|
|
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
|
|
$ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
|
|
$ RETURN
|
|
*
|
|
* SET LENX AND LENY, THE LENGTHS OF THE VECTORS X AND Y, AND SET
|
|
* UP THE START POINTS IN X AND Y.
|
|
*
|
|
IF( LSAME( TRANS, 'N' ) )THEN
|
|
LENX = N
|
|
LENY = M
|
|
ELSE
|
|
LENX = M
|
|
LENY = N
|
|
END IF
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( LENX - 1 )*INCX
|
|
END IF
|
|
IF( INCY.GT.0 )THEN
|
|
KY = 1
|
|
ELSE
|
|
KY = 1 - ( LENY - 1 )*INCY
|
|
END IF
|
|
*
|
|
* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE
|
|
* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A.
|
|
*
|
|
* FIRST FORM Y := BETA*Y.
|
|
*
|
|
IF( BETA.NE.ONE )THEN
|
|
IF( INCY.EQ.1 )THEN
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 10, I = 1, LENY
|
|
Y( I ) = ZERO
|
|
10 CONTINUE
|
|
ELSE
|
|
DO 20, I = 1, LENY
|
|
Y( I ) = BETA*Y( I )
|
|
20 CONTINUE
|
|
END IF
|
|
ELSE
|
|
IY = KY
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 30, I = 1, LENY
|
|
Y( IY ) = ZERO
|
|
IY = IY + INCY
|
|
30 CONTINUE
|
|
ELSE
|
|
DO 40, I = 1, LENY
|
|
Y( IY ) = BETA*Y( IY )
|
|
IY = IY + INCY
|
|
40 CONTINUE
|
|
END IF
|
|
END IF
|
|
END IF
|
|
IF( ALPHA.EQ.ZERO )
|
|
$ RETURN
|
|
IF( LSAME( TRANS, 'N' ) )THEN
|
|
*
|
|
* FORM Y := ALPHA*A*X + Y.
|
|
*
|
|
JX = KX
|
|
IF( INCY.EQ.1 )THEN
|
|
DO 60, J = 1, N
|
|
IF( X( JX ).NE.ZERO )THEN
|
|
TEMP = ALPHA*X( JX )
|
|
DO 50, I = 1, M
|
|
Y( I ) = Y( I ) + TEMP*A( I, J )
|
|
50 CONTINUE
|
|
END IF
|
|
JX = JX + INCX
|
|
60 CONTINUE
|
|
ELSE
|
|
DO 80, J = 1, N
|
|
IF( X( JX ).NE.ZERO )THEN
|
|
TEMP = ALPHA*X( JX )
|
|
IY = KY
|
|
DO 70, I = 1, M
|
|
Y( IY ) = Y( IY ) + TEMP*A( I, J )
|
|
IY = IY + INCY
|
|
70 CONTINUE
|
|
END IF
|
|
JX = JX + INCX
|
|
80 CONTINUE
|
|
END IF
|
|
ELSE
|
|
*
|
|
* FORM Y := ALPHA*A'*X + Y.
|
|
*
|
|
JY = KY
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 100, J = 1, N
|
|
TEMP = ZERO
|
|
DO 90, I = 1, M
|
|
TEMP = TEMP + A( I, J )*X( I )
|
|
90 CONTINUE
|
|
Y( JY ) = Y( JY ) + ALPHA*TEMP
|
|
JY = JY + INCY
|
|
100 CONTINUE
|
|
ELSE
|
|
DO 120, J = 1, N
|
|
TEMP = ZERO
|
|
IX = KX
|
|
DO 110, I = 1, M
|
|
TEMP = TEMP + A( I, J )*X( IX )
|
|
IX = IX + INCX
|
|
110 CONTINUE
|
|
Y( JY ) = Y( JY ) + ALPHA*TEMP
|
|
JY = JY + INCY
|
|
120 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* END OF DGEMV .
|
|
*
|
|
END
|
|
SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
|
|
* .. SCALAR ARGUMENTS ..
|
|
DOUBLE PRECISION ALPHA
|
|
INTEGER INCX, INCY, LDA, M, N
|
|
* .. ARRAY ARGUMENTS ..
|
|
DOUBLE PRECISION A( LDA, * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* PURPOSE
|
|
* =======
|
|
*
|
|
* DGER PERFORMS THE RANK 1 OPERATION
|
|
*
|
|
* A := ALPHA*X*Y' + A,
|
|
*
|
|
* WHERE ALPHA IS A SCALAR, X IS AN M ELEMENT VECTOR, Y IS AN N ELEMENT
|
|
* VECTOR AND A IS AN M BY N MATRIX.
|
|
*
|
|
* PARAMETERS
|
|
* ==========
|
|
*
|
|
* M - INTEGER.
|
|
* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX A.
|
|
* M MUST BE AT LEAST ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* N - INTEGER.
|
|
* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX A.
|
|
* N MUST BE AT LEAST ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* ALPHA - DOUBLE PRECISION.
|
|
* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST
|
|
* ( 1 + ( M - 1 )*ABS( INCX ) ).
|
|
* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE M
|
|
* ELEMENT VECTOR X.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* INCX - INTEGER.
|
|
* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF
|
|
* X. INCX MUST NOT BE ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST
|
|
* ( 1 + ( N - 1 )*ABS( INCY ) ).
|
|
* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE N
|
|
* ELEMENT VECTOR Y.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* INCY - INTEGER.
|
|
* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF
|
|
* Y. INCY MUST NOT BE ZERO.
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ).
|
|
* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY A MUST
|
|
* CONTAIN THE MATRIX OF COEFFICIENTS. ON EXIT, A IS
|
|
* OVERWRITTEN BY THE UPDATED MATRIX.
|
|
*
|
|
* LDA - INTEGER.
|
|
* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED
|
|
* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST
|
|
* MAX( 1, M ).
|
|
* UNCHANGED ON EXIT.
|
|
*
|
|
*
|
|
* LEVEL 2 BLAS ROUTINE.
|
|
*
|
|
* -- WRITTEN ON 22-OCTOBER-1986.
|
|
* JACK DONGARRA, ARGONNE NATIONAL LAB.
|
|
* JEREMY DU CROZ, NAG CENTRAL OFFICE.
|
|
* SVEN HAMMARLING, NAG CENTRAL OFFICE.
|
|
* RICHARD HANSON, SANDIA NATIONAL LABS.
|
|
*
|
|
*
|
|
* .. PARAMETERS ..
|
|
DOUBLE PRECISION ZERO
|
|
PARAMETER ( ZERO = 0.0D+0 )
|
|
* .. LOCAL SCALARS ..
|
|
DOUBLE PRECISION TEMP
|
|
INTEGER I, INFO, IX, J, JY, KX
|
|
* .. EXTERNAL SUBROUTINES ..
|
|
EXTERNAL XERBLA
|
|
* .. INTRINSIC FUNCTIONS ..
|
|
INTRINSIC MAX
|
|
* ..
|
|
* .. EXECUTABLE STATEMENTS ..
|
|
*
|
|
* TEST THE INPUT PARAMETERS.
|
|
*
|
|
INFO = 0
|
|
IF ( M.LT.0 )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 5
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 7
|
|
ELSE IF( LDA.LT.MAX( 1, M ) )THEN
|
|
INFO = 9
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'DGER ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* QUICK RETURN IF POSSIBLE.
|
|
*
|
|
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
|
|
$ RETURN
|
|
*
|
|
* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE
|
|
* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A.
|
|
*
|
|
IF( INCY.GT.0 )THEN
|
|
JY = 1
|
|
ELSE
|
|
JY = 1 - ( N - 1 )*INCY
|
|
END IF
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 20, J = 1, N
|
|
IF( Y( JY ).NE.ZERO )THEN
|
|
TEMP = ALPHA*Y( JY )
|
|
DO 10, I = 1, M
|
|
A( I, J ) = A( I, J ) + X( I )*TEMP
|
|
10 CONTINUE
|
|
END IF
|
|
JY = JY + INCY
|
|
20 CONTINUE
|
|
ELSE
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( M - 1 )*INCX
|
|
END IF
|
|
DO 40, J = 1, N
|
|
IF( Y( JY ).NE.ZERO )THEN
|
|
TEMP = ALPHA*Y( JY )
|
|
IX = KX
|
|
DO 30, I = 1, M
|
|
A( I, J ) = A( I, J ) + X( IX )*TEMP
|
|
IX = IX + INCX
|
|
30 CONTINUE
|
|
END IF
|
|
JY = JY + INCY
|
|
40 CONTINUE
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* END OF DGER .
|
|
*
|
|
END
|
|
subroutine dscal(n,da,dx,incx)
|
|
c
|
|
c scales a vector by a constant.
|
|
c uses unrolled loops for increment equal to one.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 3/93 to return if incx .le. 0.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision da,dx(*)
|
|
integer i,incx,m,mp1,n,nincx
|
|
c
|
|
if( n.le.0 .or. incx.le.0 )return
|
|
if(incx.eq.1)go to 20
|
|
c
|
|
c code for increment not equal to 1
|
|
c
|
|
nincx = n*incx
|
|
do 10 i = 1,nincx,incx
|
|
dx(i) = da*dx(i)
|
|
10 continue
|
|
return
|
|
c
|
|
c code for increment equal to 1
|
|
c
|
|
c
|
|
c clean-up loop
|
|
c
|
|
20 m = mod(n,5)
|
|
if( m .eq. 0 ) go to 40
|
|
do 30 i = 1,m
|
|
dx(i) = da*dx(i)
|
|
30 continue
|
|
if( n .lt. 5 ) return
|
|
40 mp1 = m + 1
|
|
do 50 i = mp1,n,5
|
|
dx(i) = da*dx(i)
|
|
dx(i + 1) = da*dx(i + 1)
|
|
dx(i + 2) = da*dx(i + 2)
|
|
dx(i + 3) = da*dx(i + 3)
|
|
dx(i + 4) = da*dx(i + 4)
|
|
50 continue
|
|
return
|
|
end
|
|
SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
|
|
* .. Scalar Arguments ..
|
|
DOUBLE PRECISION ALPHA, BETA
|
|
INTEGER INCX, INCY, N
|
|
CHARACTER*1 UPLO
|
|
* .. Array Arguments ..
|
|
DOUBLE PRECISION AP( * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* DSPMV performs the matrix-vector operation
|
|
*
|
|
* y := alpha*A*x + beta*y,
|
|
*
|
|
* where alpha and beta are scalars, x and y are n element vectors and
|
|
* A is an n by n symmetric matrix, supplied in packed form.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* UPLO - CHARACTER*1.
|
|
* On entry, UPLO specifies whether the upper or lower
|
|
* triangular part of the matrix A is supplied in the packed
|
|
* array AP as follows:
|
|
*
|
|
* UPLO = 'U' or 'u' The upper triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* UPLO = 'L' or 'l' The lower triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the order of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - DOUBLE PRECISION.
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* AP - DOUBLE PRECISION array of DIMENSION at least
|
|
* ( ( n*( n + 1 ) )/2 ).
|
|
* Before entry with UPLO = 'U' or 'u', the array AP must
|
|
* contain the upper triangular part of the symmetric matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
|
* and a( 2, 2 ) respectively, and so on.
|
|
* Before entry with UPLO = 'L' or 'l', the array AP must
|
|
* contain the lower triangular part of the symmetric matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
|
* and a( 3, 1 ) respectively, and so on.
|
|
* Unchanged on exit.
|
|
*
|
|
* X - DOUBLE PRECISION array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
|
* Before entry, the incremented array X must contain the n
|
|
* element vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* BETA - DOUBLE PRECISION.
|
|
* On entry, BETA specifies the scalar beta. When BETA is
|
|
* supplied as zero then Y need not be set on input.
|
|
* Unchanged on exit.
|
|
*
|
|
* Y - DOUBLE PRECISION array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
|
* Before entry, the incremented array Y must contain the n
|
|
* element vector y. On exit, Y is overwritten by the updated
|
|
* vector y.
|
|
*
|
|
* INCY - INTEGER.
|
|
* On entry, INCY specifies the increment for the elements of
|
|
* Y. INCY must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
DOUBLE PRECISION ONE , ZERO
|
|
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
|
* .. Local Scalars ..
|
|
DOUBLE PRECISION TEMP1, TEMP2
|
|
INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
|
|
$ .NOT.LSAME( UPLO, 'L' ) )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 6
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 9
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'DSPMV ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
|
|
$ RETURN
|
|
*
|
|
* Set up the start points in X and Y.
|
|
*
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( N - 1 )*INCX
|
|
END IF
|
|
IF( INCY.GT.0 )THEN
|
|
KY = 1
|
|
ELSE
|
|
KY = 1 - ( N - 1 )*INCY
|
|
END IF
|
|
*
|
|
* Start the operations. In this version the elements of the array AP
|
|
* are accessed sequentially with one pass through AP.
|
|
*
|
|
* First form y := beta*y.
|
|
*
|
|
IF( BETA.NE.ONE )THEN
|
|
IF( INCY.EQ.1 )THEN
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 10, I = 1, N
|
|
Y( I ) = ZERO
|
|
10 CONTINUE
|
|
ELSE
|
|
DO 20, I = 1, N
|
|
Y( I ) = BETA*Y( I )
|
|
20 CONTINUE
|
|
END IF
|
|
ELSE
|
|
IY = KY
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 30, I = 1, N
|
|
Y( IY ) = ZERO
|
|
IY = IY + INCY
|
|
30 CONTINUE
|
|
ELSE
|
|
DO 40, I = 1, N
|
|
Y( IY ) = BETA*Y( IY )
|
|
IY = IY + INCY
|
|
40 CONTINUE
|
|
END IF
|
|
END IF
|
|
END IF
|
|
IF( ALPHA.EQ.ZERO )
|
|
$ RETURN
|
|
KK = 1
|
|
IF( LSAME( UPLO, 'U' ) )THEN
|
|
*
|
|
* Form y when AP contains the upper triangle.
|
|
*
|
|
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
|
DO 60, J = 1, N
|
|
TEMP1 = ALPHA*X( J )
|
|
TEMP2 = ZERO
|
|
K = KK
|
|
DO 50, I = 1, J - 1
|
|
Y( I ) = Y( I ) + TEMP1*AP( K )
|
|
TEMP2 = TEMP2 + AP( K )*X( I )
|
|
K = K + 1
|
|
50 CONTINUE
|
|
Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2
|
|
KK = KK + J
|
|
60 CONTINUE
|
|
ELSE
|
|
JX = KX
|
|
JY = KY
|
|
DO 80, J = 1, N
|
|
TEMP1 = ALPHA*X( JX )
|
|
TEMP2 = ZERO
|
|
IX = KX
|
|
IY = KY
|
|
DO 70, K = KK, KK + J - 2
|
|
Y( IY ) = Y( IY ) + TEMP1*AP( K )
|
|
TEMP2 = TEMP2 + AP( K )*X( IX )
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
70 CONTINUE
|
|
Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2
|
|
JX = JX + INCX
|
|
JY = JY + INCY
|
|
KK = KK + J
|
|
80 CONTINUE
|
|
END IF
|
|
ELSE
|
|
*
|
|
* Form y when AP contains the lower triangle.
|
|
*
|
|
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
|
DO 100, J = 1, N
|
|
TEMP1 = ALPHA*X( J )
|
|
TEMP2 = ZERO
|
|
Y( J ) = Y( J ) + TEMP1*AP( KK )
|
|
K = KK + 1
|
|
DO 90, I = J + 1, N
|
|
Y( I ) = Y( I ) + TEMP1*AP( K )
|
|
TEMP2 = TEMP2 + AP( K )*X( I )
|
|
K = K + 1
|
|
90 CONTINUE
|
|
Y( J ) = Y( J ) + ALPHA*TEMP2
|
|
KK = KK + ( N - J + 1 )
|
|
100 CONTINUE
|
|
ELSE
|
|
JX = KX
|
|
JY = KY
|
|
DO 120, J = 1, N
|
|
TEMP1 = ALPHA*X( JX )
|
|
TEMP2 = ZERO
|
|
Y( JY ) = Y( JY ) + TEMP1*AP( KK )
|
|
IX = JX
|
|
IY = JY
|
|
DO 110, K = KK + 1, KK + N - J
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
Y( IY ) = Y( IY ) + TEMP1*AP( K )
|
|
TEMP2 = TEMP2 + AP( K )*X( IX )
|
|
110 CONTINUE
|
|
Y( JY ) = Y( JY ) + ALPHA*TEMP2
|
|
JX = JX + INCX
|
|
JY = JY + INCY
|
|
KK = KK + ( N - J + 1 )
|
|
120 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of DSPMV .
|
|
*
|
|
END
|
|
SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
|
|
* .. Scalar Arguments ..
|
|
DOUBLE PRECISION ALPHA
|
|
INTEGER INCX, INCY, N
|
|
CHARACTER*1 UPLO
|
|
* .. Array Arguments ..
|
|
DOUBLE PRECISION AP( * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* DSPR2 performs the symmetric rank 2 operation
|
|
*
|
|
* A := alpha*x*y' + alpha*y*x' + A,
|
|
*
|
|
* where alpha is a scalar, x and y are n element vectors and A is an
|
|
* n by n symmetric matrix, supplied in packed form.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* UPLO - CHARACTER*1.
|
|
* On entry, UPLO specifies whether the upper or lower
|
|
* triangular part of the matrix A is supplied in the packed
|
|
* array AP as follows:
|
|
*
|
|
* UPLO = 'U' or 'u' The upper triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* UPLO = 'L' or 'l' The lower triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the order of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - DOUBLE PRECISION.
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* X - DOUBLE PRECISION array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
|
* Before entry, the incremented array X must contain the n
|
|
* element vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* Y - DOUBLE PRECISION array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
|
* Before entry, the incremented array Y must contain the n
|
|
* element vector y.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCY - INTEGER.
|
|
* On entry, INCY specifies the increment for the elements of
|
|
* Y. INCY must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* AP - DOUBLE PRECISION array of DIMENSION at least
|
|
* ( ( n*( n + 1 ) )/2 ).
|
|
* Before entry with UPLO = 'U' or 'u', the array AP must
|
|
* contain the upper triangular part of the symmetric matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
|
* and a( 2, 2 ) respectively, and so on. On exit, the array
|
|
* AP is overwritten by the upper triangular part of the
|
|
* updated matrix.
|
|
* Before entry with UPLO = 'L' or 'l', the array AP must
|
|
* contain the lower triangular part of the symmetric matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
|
* and a( 3, 1 ) respectively, and so on. On exit, the array
|
|
* AP is overwritten by the lower triangular part of the
|
|
* updated matrix.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
DOUBLE PRECISION ZERO
|
|
PARAMETER ( ZERO = 0.0D+0 )
|
|
* .. Local Scalars ..
|
|
DOUBLE PRECISION TEMP1, TEMP2
|
|
INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
|
|
$ .NOT.LSAME( UPLO, 'L' ) )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 5
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 7
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'DSPR2 ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
|
|
$ RETURN
|
|
*
|
|
* Set up the start points in X and Y if the increments are not both
|
|
* unity.
|
|
*
|
|
IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( N - 1 )*INCX
|
|
END IF
|
|
IF( INCY.GT.0 )THEN
|
|
KY = 1
|
|
ELSE
|
|
KY = 1 - ( N - 1 )*INCY
|
|
END IF
|
|
JX = KX
|
|
JY = KY
|
|
END IF
|
|
*
|
|
* Start the operations. In this version the elements of the array AP
|
|
* are accessed sequentially with one pass through AP.
|
|
*
|
|
KK = 1
|
|
IF( LSAME( UPLO, 'U' ) )THEN
|
|
*
|
|
* Form A when upper triangle is stored in AP.
|
|
*
|
|
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
|
DO 20, J = 1, N
|
|
IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
|
|
TEMP1 = ALPHA*Y( J )
|
|
TEMP2 = ALPHA*X( J )
|
|
K = KK
|
|
DO 10, I = 1, J
|
|
AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
|
|
K = K + 1
|
|
10 CONTINUE
|
|
END IF
|
|
KK = KK + J
|
|
20 CONTINUE
|
|
ELSE
|
|
DO 40, J = 1, N
|
|
IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
|
|
TEMP1 = ALPHA*Y( JY )
|
|
TEMP2 = ALPHA*X( JX )
|
|
IX = KX
|
|
IY = KY
|
|
DO 30, K = KK, KK + J - 1
|
|
AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
30 CONTINUE
|
|
END IF
|
|
JX = JX + INCX
|
|
JY = JY + INCY
|
|
KK = KK + J
|
|
40 CONTINUE
|
|
END IF
|
|
ELSE
|
|
*
|
|
* Form A when lower triangle is stored in AP.
|
|
*
|
|
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
|
DO 60, J = 1, N
|
|
IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
|
|
TEMP1 = ALPHA*Y( J )
|
|
TEMP2 = ALPHA*X( J )
|
|
K = KK
|
|
DO 50, I = J, N
|
|
AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
|
|
K = K + 1
|
|
50 CONTINUE
|
|
END IF
|
|
KK = KK + N - J + 1
|
|
60 CONTINUE
|
|
ELSE
|
|
DO 80, J = 1, N
|
|
IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
|
|
TEMP1 = ALPHA*Y( JY )
|
|
TEMP2 = ALPHA*X( JX )
|
|
IX = JX
|
|
IY = JY
|
|
DO 70, K = KK, KK + N - J
|
|
AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
70 CONTINUE
|
|
END IF
|
|
JX = JX + INCX
|
|
JY = JY + INCY
|
|
KK = KK + N - J + 1
|
|
80 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of DSPR2 .
|
|
*
|
|
END
|
|
subroutine dswap (n,dx,incx,dy,incy)
|
|
c
|
|
c interchanges two vectors.
|
|
c uses unrolled loops for increments equal one.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dy(*),dtemp
|
|
integer i,incx,incy,ix,iy,m,mp1,n
|
|
c
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments not equal
|
|
c to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
dtemp = dx(ix)
|
|
dx(ix) = dy(iy)
|
|
dy(iy) = dtemp
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
c
|
|
c clean-up loop
|
|
c
|
|
20 m = mod(n,3)
|
|
if( m .eq. 0 ) go to 40
|
|
do 30 i = 1,m
|
|
dtemp = dx(i)
|
|
dx(i) = dy(i)
|
|
dy(i) = dtemp
|
|
30 continue
|
|
if( n .lt. 3 ) return
|
|
40 mp1 = m + 1
|
|
do 50 i = mp1,n,3
|
|
dtemp = dx(i)
|
|
dx(i) = dy(i)
|
|
dy(i) = dtemp
|
|
dtemp = dx(i + 1)
|
|
dx(i + 1) = dy(i + 1)
|
|
dy(i + 1) = dtemp
|
|
dtemp = dx(i + 2)
|
|
dx(i + 2) = dy(i + 2)
|
|
dy(i + 2) = dtemp
|
|
50 continue
|
|
return
|
|
end
|
|
subroutine zscal(n,za,zx,incx)
|
|
c
|
|
c scales a vector by a constant.
|
|
c jack dongarra, 3/11/78.
|
|
c modified 3/93 to return if incx .le. 0.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double complex za,zx(*)
|
|
integer i,incx,ix,n
|
|
c
|
|
if( n.le.0 .or. incx.le.0 )return
|
|
if(incx.eq.1)go to 20
|
|
c
|
|
c code for increment not equal to 1
|
|
c
|
|
ix = 1
|
|
do 10 i = 1,n
|
|
zx(ix) = za*zx(ix)
|
|
ix = ix + incx
|
|
10 continue
|
|
return
|
|
c
|
|
c code for increment equal to 1
|
|
c
|
|
20 do 30 i = 1,n
|
|
zx(i) = za*zx(i)
|
|
30 continue
|
|
return
|
|
end
|
|
integer function idamax(n,dx,incx)
|
|
c
|
|
c finds the index of element having max. absolute value.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 3/93 to return if incx .le. 0.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dmax
|
|
integer i,incx,ix,n
|
|
c
|
|
idamax = 0
|
|
if( n.lt.1 .or. incx.le.0 ) return
|
|
idamax = 1
|
|
if(n.eq.1)return
|
|
if(incx.eq.1)go to 20
|
|
c
|
|
c code for increment not equal to 1
|
|
c
|
|
ix = 1
|
|
dmax = dabs(dx(1))
|
|
ix = ix + incx
|
|
do 10 i = 2,n
|
|
if(dabs(dx(ix)).le.dmax) go to 5
|
|
idamax = i
|
|
dmax = dabs(dx(ix))
|
|
5 ix = ix + incx
|
|
10 continue
|
|
return
|
|
c
|
|
c code for increment equal to 1
|
|
c
|
|
20 dmax = dabs(dx(1))
|
|
do 30 i = 2,n
|
|
if(dabs(dx(i)).le.dmax) go to 30
|
|
idamax = i
|
|
dmax = dabs(dx(i))
|
|
30 continue
|
|
return
|
|
end
|
|
SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
|
|
$ BETA, C, LDC )
|
|
* .. Scalar Arguments ..
|
|
CHARACTER*1 TRANSA, TRANSB
|
|
INTEGER M, N, K, LDA, LDB, LDC
|
|
COMPLEX*16 ALPHA, BETA
|
|
* .. Array Arguments ..
|
|
COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* ZGEMM performs one of the matrix-matrix operations
|
|
*
|
|
* C := alpha*op( A )*op( B ) + beta*C,
|
|
*
|
|
* where op( X ) is one of
|
|
*
|
|
* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ),
|
|
*
|
|
* alpha and beta are scalars, and A, B and C are matrices, with op( A )
|
|
* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* TRANSA - CHARACTER*1.
|
|
* On entry, TRANSA specifies the form of op( A ) to be used in
|
|
* the matrix multiplication as follows:
|
|
*
|
|
* TRANSA = 'N' or 'n', op( A ) = A.
|
|
*
|
|
* TRANSA = 'T' or 't', op( A ) = A'.
|
|
*
|
|
* TRANSA = 'C' or 'c', op( A ) = conjg( A' ).
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* TRANSB - CHARACTER*1.
|
|
* On entry, TRANSB specifies the form of op( B ) to be used in
|
|
* the matrix multiplication as follows:
|
|
*
|
|
* TRANSB = 'N' or 'n', op( B ) = B.
|
|
*
|
|
* TRANSB = 'T' or 't', op( B ) = B'.
|
|
*
|
|
* TRANSB = 'C' or 'c', op( B ) = conjg( B' ).
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* M - INTEGER.
|
|
* On entry, M specifies the number of rows of the matrix
|
|
* op( A ) and of the matrix C. M must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the number of columns of the matrix
|
|
* op( B ) and the number of columns of the matrix C. N must be
|
|
* at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* K - INTEGER.
|
|
* On entry, K specifies the number of columns of the matrix
|
|
* op( A ) and the number of rows of the matrix op( B ). K must
|
|
* be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - COMPLEX*16 .
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
|
|
* k when TRANSA = 'N' or 'n', and is m otherwise.
|
|
* Before entry with TRANSA = 'N' or 'n', the leading m by k
|
|
* part of the array A must contain the matrix A, otherwise
|
|
* the leading k by m part of the array A must contain the
|
|
* matrix A.
|
|
* Unchanged on exit.
|
|
*
|
|
* LDA - INTEGER.
|
|
* On entry, LDA specifies the first dimension of A as declared
|
|
* in the calling (sub) program. When TRANSA = 'N' or 'n' then
|
|
* LDA must be at least max( 1, m ), otherwise LDA must be at
|
|
* least max( 1, k ).
|
|
* Unchanged on exit.
|
|
*
|
|
* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is
|
|
* n when TRANSB = 'N' or 'n', and is k otherwise.
|
|
* Before entry with TRANSB = 'N' or 'n', the leading k by n
|
|
* part of the array B must contain the matrix B, otherwise
|
|
* the leading n by k part of the array B must contain the
|
|
* matrix B.
|
|
* Unchanged on exit.
|
|
*
|
|
* LDB - INTEGER.
|
|
* On entry, LDB specifies the first dimension of B as declared
|
|
* in the calling (sub) program. When TRANSB = 'N' or 'n' then
|
|
* LDB must be at least max( 1, k ), otherwise LDB must be at
|
|
* least max( 1, n ).
|
|
* Unchanged on exit.
|
|
*
|
|
* BETA - COMPLEX*16 .
|
|
* On entry, BETA specifies the scalar beta. When BETA is
|
|
* supplied as zero then C need not be set on input.
|
|
* Unchanged on exit.
|
|
*
|
|
* C - COMPLEX*16 array of DIMENSION ( LDC, n ).
|
|
* Before entry, the leading m by n part of the array C must
|
|
* contain the matrix C, except when beta is zero, in which
|
|
* case C need not be set on entry.
|
|
* On exit, the array C is overwritten by the m by n matrix
|
|
* ( alpha*op( A )*op( B ) + beta*C ).
|
|
*
|
|
* LDC - INTEGER.
|
|
* On entry, LDC specifies the first dimension of C as declared
|
|
* in the calling (sub) program. LDC must be at least
|
|
* max( 1, m ).
|
|
* Unchanged on exit.
|
|
*
|
|
*
|
|
* Level 3 Blas routine.
|
|
*
|
|
* -- Written on 8-February-1989.
|
|
* Jack Dongarra, Argonne National Laboratory.
|
|
* Iain Duff, AERE Harwell.
|
|
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
|
* Sven Hammarling, Numerical Algorithms Group Ltd.
|
|
*
|
|
*
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC DCONJG, MAX
|
|
* .. Local Scalars ..
|
|
LOGICAL CONJA, CONJB, NOTA, NOTB
|
|
INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
|
|
COMPLEX*16 TEMP
|
|
* .. Parameters ..
|
|
COMPLEX*16 ONE
|
|
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
|
|
COMPLEX*16 ZERO
|
|
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Set NOTA and NOTB as true if A and B respectively are not
|
|
* conjugated or transposed, set CONJA and CONJB as true if A and
|
|
* B respectively are to be transposed but not conjugated and set
|
|
* NROWA, NCOLA and NROWB as the number of rows and columns of A
|
|
* and the number of rows of B respectively.
|
|
*
|
|
NOTA = LSAME( TRANSA, 'N' )
|
|
NOTB = LSAME( TRANSB, 'N' )
|
|
CONJA = LSAME( TRANSA, 'C' )
|
|
CONJB = LSAME( TRANSB, 'C' )
|
|
IF( NOTA )THEN
|
|
NROWA = M
|
|
NCOLA = K
|
|
ELSE
|
|
NROWA = K
|
|
NCOLA = M
|
|
END IF
|
|
IF( NOTB )THEN
|
|
NROWB = K
|
|
ELSE
|
|
NROWB = N
|
|
END IF
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF( ( .NOT.NOTA ).AND.
|
|
$ ( .NOT.CONJA ).AND.
|
|
$ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN
|
|
INFO = 1
|
|
ELSE IF( ( .NOT.NOTB ).AND.
|
|
$ ( .NOT.CONJB ).AND.
|
|
$ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN
|
|
INFO = 2
|
|
ELSE IF( M .LT.0 )THEN
|
|
INFO = 3
|
|
ELSE IF( N .LT.0 )THEN
|
|
INFO = 4
|
|
ELSE IF( K .LT.0 )THEN
|
|
INFO = 5
|
|
ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
|
|
INFO = 8
|
|
ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
|
|
INFO = 10
|
|
ELSE IF( LDC.LT.MAX( 1, M ) )THEN
|
|
INFO = 13
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'ZGEMM ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
|
|
$ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
|
|
$ RETURN
|
|
*
|
|
* And when alpha.eq.zero.
|
|
*
|
|
IF( ALPHA.EQ.ZERO )THEN
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 20, J = 1, N
|
|
DO 10, I = 1, M
|
|
C( I, J ) = ZERO
|
|
10 CONTINUE
|
|
20 CONTINUE
|
|
ELSE
|
|
DO 40, J = 1, N
|
|
DO 30, I = 1, M
|
|
C( I, J ) = BETA*C( I, J )
|
|
30 CONTINUE
|
|
40 CONTINUE
|
|
END IF
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Start the operations.
|
|
*
|
|
IF( NOTB )THEN
|
|
IF( NOTA )THEN
|
|
*
|
|
* Form C := alpha*A*B + beta*C.
|
|
*
|
|
DO 90, J = 1, N
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 50, I = 1, M
|
|
C( I, J ) = ZERO
|
|
50 CONTINUE
|
|
ELSE IF( BETA.NE.ONE )THEN
|
|
DO 60, I = 1, M
|
|
C( I, J ) = BETA*C( I, J )
|
|
60 CONTINUE
|
|
END IF
|
|
DO 80, L = 1, K
|
|
IF( B( L, J ).NE.ZERO )THEN
|
|
TEMP = ALPHA*B( L, J )
|
|
DO 70, I = 1, M
|
|
C( I, J ) = C( I, J ) + TEMP*A( I, L )
|
|
70 CONTINUE
|
|
END IF
|
|
80 CONTINUE
|
|
90 CONTINUE
|
|
ELSE IF( CONJA )THEN
|
|
*
|
|
* Form C := alpha*conjg( A' )*B + beta*C.
|
|
*
|
|
DO 120, J = 1, N
|
|
DO 110, I = 1, M
|
|
TEMP = ZERO
|
|
DO 100, L = 1, K
|
|
TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J )
|
|
100 CONTINUE
|
|
IF( BETA.EQ.ZERO )THEN
|
|
C( I, J ) = ALPHA*TEMP
|
|
ELSE
|
|
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
|
END IF
|
|
110 CONTINUE
|
|
120 CONTINUE
|
|
ELSE
|
|
*
|
|
* Form C := alpha*A'*B + beta*C
|
|
*
|
|
DO 150, J = 1, N
|
|
DO 140, I = 1, M
|
|
TEMP = ZERO
|
|
DO 130, L = 1, K
|
|
TEMP = TEMP + A( L, I )*B( L, J )
|
|
130 CONTINUE
|
|
IF( BETA.EQ.ZERO )THEN
|
|
C( I, J ) = ALPHA*TEMP
|
|
ELSE
|
|
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
|
END IF
|
|
140 CONTINUE
|
|
150 CONTINUE
|
|
END IF
|
|
ELSE IF( NOTA )THEN
|
|
IF( CONJB )THEN
|
|
*
|
|
* Form C := alpha*A*conjg( B' ) + beta*C.
|
|
*
|
|
DO 200, J = 1, N
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 160, I = 1, M
|
|
C( I, J ) = ZERO
|
|
160 CONTINUE
|
|
ELSE IF( BETA.NE.ONE )THEN
|
|
DO 170, I = 1, M
|
|
C( I, J ) = BETA*C( I, J )
|
|
170 CONTINUE
|
|
END IF
|
|
DO 190, L = 1, K
|
|
IF( B( J, L ).NE.ZERO )THEN
|
|
TEMP = ALPHA*DCONJG( B( J, L ) )
|
|
DO 180, I = 1, M
|
|
C( I, J ) = C( I, J ) + TEMP*A( I, L )
|
|
180 CONTINUE
|
|
END IF
|
|
190 CONTINUE
|
|
200 CONTINUE
|
|
ELSE
|
|
*
|
|
* Form C := alpha*A*B' + beta*C
|
|
*
|
|
DO 250, J = 1, N
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 210, I = 1, M
|
|
C( I, J ) = ZERO
|
|
210 CONTINUE
|
|
ELSE IF( BETA.NE.ONE )THEN
|
|
DO 220, I = 1, M
|
|
C( I, J ) = BETA*C( I, J )
|
|
220 CONTINUE
|
|
END IF
|
|
DO 240, L = 1, K
|
|
IF( B( J, L ).NE.ZERO )THEN
|
|
TEMP = ALPHA*B( J, L )
|
|
DO 230, I = 1, M
|
|
C( I, J ) = C( I, J ) + TEMP*A( I, L )
|
|
230 CONTINUE
|
|
END IF
|
|
240 CONTINUE
|
|
250 CONTINUE
|
|
END IF
|
|
ELSE IF( CONJA )THEN
|
|
IF( CONJB )THEN
|
|
*
|
|
* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C.
|
|
*
|
|
DO 280, J = 1, N
|
|
DO 270, I = 1, M
|
|
TEMP = ZERO
|
|
DO 260, L = 1, K
|
|
TEMP = TEMP +
|
|
$ DCONJG( A( L, I ) )*DCONJG( B( J, L ) )
|
|
260 CONTINUE
|
|
IF( BETA.EQ.ZERO )THEN
|
|
C( I, J ) = ALPHA*TEMP
|
|
ELSE
|
|
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
|
END IF
|
|
270 CONTINUE
|
|
280 CONTINUE
|
|
ELSE
|
|
*
|
|
* Form C := alpha*conjg( A' )*B' + beta*C
|
|
*
|
|
DO 310, J = 1, N
|
|
DO 300, I = 1, M
|
|
TEMP = ZERO
|
|
DO 290, L = 1, K
|
|
TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L )
|
|
290 CONTINUE
|
|
IF( BETA.EQ.ZERO )THEN
|
|
C( I, J ) = ALPHA*TEMP
|
|
ELSE
|
|
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
|
END IF
|
|
300 CONTINUE
|
|
310 CONTINUE
|
|
END IF
|
|
ELSE
|
|
IF( CONJB )THEN
|
|
*
|
|
* Form C := alpha*A'*conjg( B' ) + beta*C
|
|
*
|
|
DO 340, J = 1, N
|
|
DO 330, I = 1, M
|
|
TEMP = ZERO
|
|
DO 320, L = 1, K
|
|
TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) )
|
|
320 CONTINUE
|
|
IF( BETA.EQ.ZERO )THEN
|
|
C( I, J ) = ALPHA*TEMP
|
|
ELSE
|
|
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
|
END IF
|
|
330 CONTINUE
|
|
340 CONTINUE
|
|
ELSE
|
|
*
|
|
* Form C := alpha*A'*B' + beta*C
|
|
*
|
|
DO 370, J = 1, N
|
|
DO 360, I = 1, M
|
|
TEMP = ZERO
|
|
DO 350, L = 1, K
|
|
TEMP = TEMP + A( L, I )*B( J, L )
|
|
350 CONTINUE
|
|
IF( BETA.EQ.ZERO )THEN
|
|
C( I, J ) = ALPHA*TEMP
|
|
ELSE
|
|
C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
|
|
END IF
|
|
360 CONTINUE
|
|
370 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of ZGEMM .
|
|
*
|
|
END
|
|
subroutine zswap (n,zx,incx,zy,incy)
|
|
c
|
|
c interchanges two vectors.
|
|
c jack dongarra, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double complex zx(*),zy(*),ztemp
|
|
integer i,incx,incy,ix,iy,n
|
|
c
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments not equal
|
|
c to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
ztemp = zx(ix)
|
|
zx(ix) = zy(iy)
|
|
zy(iy) = ztemp
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
20 do 30 i = 1,n
|
|
ztemp = zx(i)
|
|
zx(i) = zy(i)
|
|
zy(i) = ztemp
|
|
30 continue
|
|
return
|
|
end
|
|
subroutine zaxpy(n,za,zx,incx,zy,incy)
|
|
c
|
|
c constant times a vector plus a vector.
|
|
c jack dongarra, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double complex zx(*),zy(*),za
|
|
integer i,incx,incy,ix,iy,n
|
|
double precision dcabs1
|
|
if(n.le.0)return
|
|
if (dcabs1(za) .eq. 0.0d0) return
|
|
if (incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments
|
|
c not equal to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
zy(iy) = zy(iy) + za*zx(ix)
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
20 do 30 i = 1,n
|
|
zy(i) = zy(i) + za*zx(i)
|
|
30 continue
|
|
return
|
|
end
|
|
subroutine zdscal(n,da,zx,incx)
|
|
c
|
|
c scales a vector by a constant.
|
|
c jack dongarra, 3/11/78.
|
|
c modified 3/93 to return if incx .le. 0.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double complex zx(*)
|
|
double precision da
|
|
integer i,incx,ix,n
|
|
c
|
|
if( n.le.0 .or. incx.le.0 )return
|
|
if(incx.eq.1)go to 20
|
|
c
|
|
c code for increment not equal to 1
|
|
c
|
|
ix = 1
|
|
do 10 i = 1,n
|
|
zx(ix) = dcmplx(da,0.0d0)*zx(ix)
|
|
ix = ix + incx
|
|
10 continue
|
|
return
|
|
c
|
|
c code for increment equal to 1
|
|
c
|
|
20 do 30 i = 1,n
|
|
zx(i) = dcmplx(da,0.0d0)*zx(i)
|
|
30 continue
|
|
return
|
|
end
|
|
DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX )
|
|
* .. Scalar Arguments ..
|
|
INTEGER INCX, N
|
|
* .. Array Arguments ..
|
|
COMPLEX*16 X( * )
|
|
* ..
|
|
*
|
|
* DZNRM2 returns the euclidean norm of a vector via the function
|
|
* name, so that
|
|
*
|
|
* DZNRM2 := sqrt( conjg( x' )*x )
|
|
*
|
|
*
|
|
*
|
|
* -- This version written on 25-October-1982.
|
|
* Modified on 14-October-1993 to inline the call to ZLASSQ.
|
|
* Sven Hammarling, Nag Ltd.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
DOUBLE PRECISION ONE , ZERO
|
|
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
|
* .. Local Scalars ..
|
|
INTEGER IX
|
|
DOUBLE PRECISION NORM, SCALE, SSQ, TEMP
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, DIMAG, DBLE, SQRT
|
|
* ..
|
|
* .. Executable Statements ..
|
|
IF( N.LT.1 .OR. INCX.LT.1 )THEN
|
|
NORM = ZERO
|
|
ELSE
|
|
SCALE = ZERO
|
|
SSQ = ONE
|
|
* The following loop is equivalent to this call to the LAPACK
|
|
* auxiliary routine:
|
|
* CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
|
|
*
|
|
DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
|
|
IF( DBLE( X( IX ) ).NE.ZERO )THEN
|
|
TEMP = ABS( DBLE( X( IX ) ) )
|
|
IF( SCALE.LT.TEMP )THEN
|
|
SSQ = ONE + SSQ*( SCALE/TEMP )**2
|
|
SCALE = TEMP
|
|
ELSE
|
|
SSQ = SSQ + ( TEMP/SCALE )**2
|
|
END IF
|
|
END IF
|
|
IF( DIMAG( X( IX ) ).NE.ZERO )THEN
|
|
TEMP = ABS( DIMAG( X( IX ) ) )
|
|
IF( SCALE.LT.TEMP )THEN
|
|
SSQ = ONE + SSQ*( SCALE/TEMP )**2
|
|
SCALE = TEMP
|
|
ELSE
|
|
SSQ = SSQ + ( TEMP/SCALE )**2
|
|
END IF
|
|
END IF
|
|
10 CONTINUE
|
|
NORM = SCALE * SQRT( SSQ )
|
|
END IF
|
|
*
|
|
DZNRM2 = NORM
|
|
RETURN
|
|
*
|
|
* End of DZNRM2.
|
|
*
|
|
END
|
|
SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
|
|
$ BETA, Y, INCY )
|
|
* .. Scalar Arguments ..
|
|
COMPLEX*16 ALPHA, BETA
|
|
INTEGER INCX, INCY, LDA, M, N
|
|
CHARACTER*1 TRANS
|
|
* .. Array Arguments ..
|
|
COMPLEX*16 A( LDA, * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* ZGEMV performs one of the matrix-vector operations
|
|
*
|
|
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or
|
|
*
|
|
* y := alpha*conjg( A' )*x + beta*y,
|
|
*
|
|
* where alpha and beta are scalars, x and y are vectors and A is an
|
|
* m by n matrix.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* TRANS - CHARACTER*1.
|
|
* On entry, TRANS specifies the operation to be performed as
|
|
* follows:
|
|
*
|
|
* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
|
*
|
|
* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
|
|
*
|
|
* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y.
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* M - INTEGER.
|
|
* On entry, M specifies the number of rows of the matrix A.
|
|
* M must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the number of columns of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - COMPLEX*16 .
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* A - COMPLEX*16 array of DIMENSION ( LDA, n ).
|
|
* Before entry, the leading m by n part of the array A must
|
|
* contain the matrix of coefficients.
|
|
* Unchanged on exit.
|
|
*
|
|
* LDA - INTEGER.
|
|
* On entry, LDA specifies the first dimension of A as declared
|
|
* in the calling (sub) program. LDA must be at least
|
|
* max( 1, m ).
|
|
* Unchanged on exit.
|
|
*
|
|
* X - COMPLEX*16 array of DIMENSION at least
|
|
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
|
* and at least
|
|
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
|
* Before entry, the incremented array X must contain the
|
|
* vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* BETA - COMPLEX*16 .
|
|
* On entry, BETA specifies the scalar beta. When BETA is
|
|
* supplied as zero then Y need not be set on input.
|
|
* Unchanged on exit.
|
|
*
|
|
* Y - COMPLEX*16 array of DIMENSION at least
|
|
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
|
* and at least
|
|
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
|
* Before entry with BETA non-zero, the incremented array Y
|
|
* must contain the vector y. On exit, Y is overwritten by the
|
|
* updated vector y.
|
|
*
|
|
* INCY - INTEGER.
|
|
* On entry, INCY specifies the increment for the elements of
|
|
* Y. INCY must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
COMPLEX*16 ONE
|
|
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
|
|
COMPLEX*16 ZERO
|
|
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
|
* .. Local Scalars ..
|
|
COMPLEX*16 TEMP
|
|
INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
|
|
LOGICAL NOCONJ
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC DCONJG, MAX
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( .NOT.LSAME( TRANS, 'N' ).AND.
|
|
$ .NOT.LSAME( TRANS, 'T' ).AND.
|
|
$ .NOT.LSAME( TRANS, 'C' ) )THEN
|
|
INFO = 1
|
|
ELSE IF( M.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 3
|
|
ELSE IF( LDA.LT.MAX( 1, M ) )THEN
|
|
INFO = 6
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 8
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 11
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'ZGEMV ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
|
|
$ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
|
|
$ RETURN
|
|
*
|
|
NOCONJ = LSAME( TRANS, 'T' )
|
|
*
|
|
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
|
* up the start points in X and Y.
|
|
*
|
|
IF( LSAME( TRANS, 'N' ) )THEN
|
|
LENX = N
|
|
LENY = M
|
|
ELSE
|
|
LENX = M
|
|
LENY = N
|
|
END IF
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( LENX - 1 )*INCX
|
|
END IF
|
|
IF( INCY.GT.0 )THEN
|
|
KY = 1
|
|
ELSE
|
|
KY = 1 - ( LENY - 1 )*INCY
|
|
END IF
|
|
*
|
|
* Start the operations. In this version the elements of A are
|
|
* accessed sequentially with one pass through A.
|
|
*
|
|
* First form y := beta*y.
|
|
*
|
|
IF( BETA.NE.ONE )THEN
|
|
IF( INCY.EQ.1 )THEN
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 10, I = 1, LENY
|
|
Y( I ) = ZERO
|
|
10 CONTINUE
|
|
ELSE
|
|
DO 20, I = 1, LENY
|
|
Y( I ) = BETA*Y( I )
|
|
20 CONTINUE
|
|
END IF
|
|
ELSE
|
|
IY = KY
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 30, I = 1, LENY
|
|
Y( IY ) = ZERO
|
|
IY = IY + INCY
|
|
30 CONTINUE
|
|
ELSE
|
|
DO 40, I = 1, LENY
|
|
Y( IY ) = BETA*Y( IY )
|
|
IY = IY + INCY
|
|
40 CONTINUE
|
|
END IF
|
|
END IF
|
|
END IF
|
|
IF( ALPHA.EQ.ZERO )
|
|
$ RETURN
|
|
IF( LSAME( TRANS, 'N' ) )THEN
|
|
*
|
|
* Form y := alpha*A*x + y.
|
|
*
|
|
JX = KX
|
|
IF( INCY.EQ.1 )THEN
|
|
DO 60, J = 1, N
|
|
IF( X( JX ).NE.ZERO )THEN
|
|
TEMP = ALPHA*X( JX )
|
|
DO 50, I = 1, M
|
|
Y( I ) = Y( I ) + TEMP*A( I, J )
|
|
50 CONTINUE
|
|
END IF
|
|
JX = JX + INCX
|
|
60 CONTINUE
|
|
ELSE
|
|
DO 80, J = 1, N
|
|
IF( X( JX ).NE.ZERO )THEN
|
|
TEMP = ALPHA*X( JX )
|
|
IY = KY
|
|
DO 70, I = 1, M
|
|
Y( IY ) = Y( IY ) + TEMP*A( I, J )
|
|
IY = IY + INCY
|
|
70 CONTINUE
|
|
END IF
|
|
JX = JX + INCX
|
|
80 CONTINUE
|
|
END IF
|
|
ELSE
|
|
*
|
|
* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y.
|
|
*
|
|
JY = KY
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 110, J = 1, N
|
|
TEMP = ZERO
|
|
IF( NOCONJ )THEN
|
|
DO 90, I = 1, M
|
|
TEMP = TEMP + A( I, J )*X( I )
|
|
90 CONTINUE
|
|
ELSE
|
|
DO 100, I = 1, M
|
|
TEMP = TEMP + DCONJG( A( I, J ) )*X( I )
|
|
100 CONTINUE
|
|
END IF
|
|
Y( JY ) = Y( JY ) + ALPHA*TEMP
|
|
JY = JY + INCY
|
|
110 CONTINUE
|
|
ELSE
|
|
DO 140, J = 1, N
|
|
TEMP = ZERO
|
|
IX = KX
|
|
IF( NOCONJ )THEN
|
|
DO 120, I = 1, M
|
|
TEMP = TEMP + A( I, J )*X( IX )
|
|
IX = IX + INCX
|
|
120 CONTINUE
|
|
ELSE
|
|
DO 130, I = 1, M
|
|
TEMP = TEMP + DCONJG( A( I, J ) )*X( IX )
|
|
IX = IX + INCX
|
|
130 CONTINUE
|
|
END IF
|
|
Y( JY ) = Y( JY ) + ALPHA*TEMP
|
|
JY = JY + INCY
|
|
140 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of ZGEMV .
|
|
*
|
|
END
|
|
subroutine zcopy(n,zx,incx,zy,incy)
|
|
c
|
|
c copies a vector, x, to a vector, y.
|
|
c jack dongarra, linpack, 4/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double complex zx(*),zy(*)
|
|
integer i,incx,incy,ix,iy,n
|
|
c
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments
|
|
c not equal to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
zy(iy) = zx(ix)
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
20 do 30 i = 1,n
|
|
zy(i) = zx(i)
|
|
30 continue
|
|
return
|
|
end
|
|
subroutine dcopy(n,dx,incx,dy,incy)
|
|
c
|
|
c copies a vector, x, to a vector, y.
|
|
c uses unrolled loops for increments equal to one.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dy(*)
|
|
integer i,incx,incy,ix,iy,m,mp1,n
|
|
c
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments
|
|
c not equal to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
dy(iy) = dx(ix)
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
c
|
|
c clean-up loop
|
|
c
|
|
20 m = mod(n,7)
|
|
if( m .eq. 0 ) go to 40
|
|
do 30 i = 1,m
|
|
dy(i) = dx(i)
|
|
30 continue
|
|
if( n .lt. 7 ) return
|
|
40 mp1 = m + 1
|
|
do 50 i = mp1,n,7
|
|
dy(i) = dx(i)
|
|
dy(i + 1) = dx(i + 1)
|
|
dy(i + 2) = dx(i + 2)
|
|
dy(i + 3) = dx(i + 3)
|
|
dy(i + 4) = dx(i + 4)
|
|
dy(i + 5) = dx(i + 5)
|
|
dy(i + 6) = dx(i + 6)
|
|
50 continue
|
|
return
|
|
end
|
|
double complex function zdotu(n,zx,incx,zy,incy)
|
|
c
|
|
c forms the dot product of two vectors.
|
|
c jack dongarra, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double complex zx(*),zy(*),ztemp
|
|
integer i,incx,incy,ix,iy,n
|
|
ztemp = (0.0d0,0.0d0)
|
|
zdotu = (0.0d0,0.0d0)
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments
|
|
c not equal to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
ztemp = ztemp + zx(ix)*zy(iy)
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
zdotu = ztemp
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
20 do 30 i = 1,n
|
|
ztemp = ztemp + zx(i)*zy(i)
|
|
30 continue
|
|
zdotu = ztemp
|
|
return
|
|
end
|
|
double precision function dcabs1(z)
|
|
double complex z,zz
|
|
double precision t(2)
|
|
equivalence (zz,t(1))
|
|
zz = z
|
|
dcabs1 = dabs(t(1)) + dabs(t(2))
|
|
return
|
|
end
|
|
integer function izamax(n,zx,incx)
|
|
c
|
|
c finds the index of element having max. absolute value.
|
|
c jack dongarra, 1/15/85.
|
|
c modified 3/93 to return if incx .le. 0.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double complex zx(*)
|
|
double precision smax
|
|
integer i,incx,ix,n
|
|
double precision dcabs1
|
|
c
|
|
izamax = 0
|
|
if( n.lt.1 .or. incx.le.0 )return
|
|
izamax = 1
|
|
if(n.eq.1)return
|
|
if(incx.eq.1)go to 20
|
|
c
|
|
c code for increment not equal to 1
|
|
c
|
|
ix = 1
|
|
smax = dcabs1(zx(1))
|
|
ix = ix + incx
|
|
do 10 i = 2,n
|
|
if(dcabs1(zx(ix)).le.smax) go to 5
|
|
izamax = i
|
|
smax = dcabs1(zx(ix))
|
|
5 ix = ix + incx
|
|
10 continue
|
|
return
|
|
c
|
|
c code for increment equal to 1
|
|
c
|
|
20 smax = dcabs1(zx(1))
|
|
do 30 i = 2,n
|
|
if(dcabs1(zx(i)).le.smax) go to 30
|
|
izamax = i
|
|
smax = dcabs1(zx(i))
|
|
30 continue
|
|
return
|
|
end
|
|
SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
|
|
* .. Scalar Arguments ..
|
|
COMPLEX*16 ALPHA
|
|
INTEGER INCX, INCY, LDA, M, N
|
|
* .. Array Arguments ..
|
|
COMPLEX*16 A( LDA, * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* ZGERU performs the rank 1 operation
|
|
*
|
|
* A := alpha*x*y' + A,
|
|
*
|
|
* where alpha is a scalar, x is an m element vector, y is an n element
|
|
* vector and A is an m by n matrix.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* M - INTEGER.
|
|
* On entry, M specifies the number of rows of the matrix A.
|
|
* M must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the number of columns of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - COMPLEX*16 .
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* X - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( m - 1 )*abs( INCX ) ).
|
|
* Before entry, the incremented array X must contain the m
|
|
* element vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* Y - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
|
* Before entry, the incremented array Y must contain the n
|
|
* element vector y.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCY - INTEGER.
|
|
* On entry, INCY specifies the increment for the elements of
|
|
* Y. INCY must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* A - COMPLEX*16 array of DIMENSION ( LDA, n ).
|
|
* Before entry, the leading m by n part of the array A must
|
|
* contain the matrix of coefficients. On exit, A is
|
|
* overwritten by the updated matrix.
|
|
*
|
|
* LDA - INTEGER.
|
|
* On entry, LDA specifies the first dimension of A as declared
|
|
* in the calling (sub) program. LDA must be at least
|
|
* max( 1, m ).
|
|
* Unchanged on exit.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
COMPLEX*16 ZERO
|
|
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
|
* .. Local Scalars ..
|
|
COMPLEX*16 TEMP
|
|
INTEGER I, INFO, IX, J, JY, KX
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC MAX
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( M.LT.0 )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 5
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 7
|
|
ELSE IF( LDA.LT.MAX( 1, M ) )THEN
|
|
INFO = 9
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'ZGERU ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
|
|
$ RETURN
|
|
*
|
|
* Start the operations. In this version the elements of A are
|
|
* accessed sequentially with one pass through A.
|
|
*
|
|
IF( INCY.GT.0 )THEN
|
|
JY = 1
|
|
ELSE
|
|
JY = 1 - ( N - 1 )*INCY
|
|
END IF
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 20, J = 1, N
|
|
IF( Y( JY ).NE.ZERO )THEN
|
|
TEMP = ALPHA*Y( JY )
|
|
DO 10, I = 1, M
|
|
A( I, J ) = A( I, J ) + X( I )*TEMP
|
|
10 CONTINUE
|
|
END IF
|
|
JY = JY + INCY
|
|
20 CONTINUE
|
|
ELSE
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( M - 1 )*INCX
|
|
END IF
|
|
DO 40, J = 1, N
|
|
IF( Y( JY ).NE.ZERO )THEN
|
|
TEMP = ALPHA*Y( JY )
|
|
IX = KX
|
|
DO 30, I = 1, M
|
|
A( I, J ) = A( I, J ) + X( IX )*TEMP
|
|
IX = IX + INCX
|
|
30 CONTINUE
|
|
END IF
|
|
JY = JY + INCY
|
|
40 CONTINUE
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of ZGERU .
|
|
*
|
|
END
|
|
SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP )
|
|
* .. Scalar Arguments ..
|
|
DOUBLE PRECISION ALPHA
|
|
INTEGER INCX, N
|
|
CHARACTER*1 UPLO
|
|
* .. Array Arguments ..
|
|
DOUBLE PRECISION AP( * ), X( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* DSPR performs the symmetric rank 1 operation
|
|
*
|
|
* A := alpha*x*x' + A,
|
|
*
|
|
* where alpha is a real scalar, x is an n element vector and A is an
|
|
* n by n symmetric matrix, supplied in packed form.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* UPLO - CHARACTER*1.
|
|
* On entry, UPLO specifies whether the upper or lower
|
|
* triangular part of the matrix A is supplied in the packed
|
|
* array AP as follows:
|
|
*
|
|
* UPLO = 'U' or 'u' The upper triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* UPLO = 'L' or 'l' The lower triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the order of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - DOUBLE PRECISION.
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* X - DOUBLE PRECISION array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
|
* Before entry, the incremented array X must contain the n
|
|
* element vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* AP - DOUBLE PRECISION array of DIMENSION at least
|
|
* ( ( n*( n + 1 ) )/2 ).
|
|
* Before entry with UPLO = 'U' or 'u', the array AP must
|
|
* contain the upper triangular part of the symmetric matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
|
* and a( 2, 2 ) respectively, and so on. On exit, the array
|
|
* AP is overwritten by the upper triangular part of the
|
|
* updated matrix.
|
|
* Before entry with UPLO = 'L' or 'l', the array AP must
|
|
* contain the lower triangular part of the symmetric matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
|
* and a( 3, 1 ) respectively, and so on. On exit, the array
|
|
* AP is overwritten by the lower triangular part of the
|
|
* updated matrix.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
DOUBLE PRECISION ZERO
|
|
PARAMETER ( ZERO = 0.0D+0 )
|
|
* .. Local Scalars ..
|
|
DOUBLE PRECISION TEMP
|
|
INTEGER I, INFO, IX, J, JX, K, KK, KX
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
|
|
$ .NOT.LSAME( UPLO, 'L' ) )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 5
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'DSPR ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
|
|
$ RETURN
|
|
*
|
|
* Set the start point in X if the increment is not unity.
|
|
*
|
|
IF( INCX.LE.0 )THEN
|
|
KX = 1 - ( N - 1 )*INCX
|
|
ELSE IF( INCX.NE.1 )THEN
|
|
KX = 1
|
|
END IF
|
|
*
|
|
* Start the operations. In this version the elements of the array AP
|
|
* are accessed sequentially with one pass through AP.
|
|
*
|
|
KK = 1
|
|
IF( LSAME( UPLO, 'U' ) )THEN
|
|
*
|
|
* Form A when upper triangle is stored in AP.
|
|
*
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 20, J = 1, N
|
|
IF( X( J ).NE.ZERO )THEN
|
|
TEMP = ALPHA*X( J )
|
|
K = KK
|
|
DO 10, I = 1, J
|
|
AP( K ) = AP( K ) + X( I )*TEMP
|
|
K = K + 1
|
|
10 CONTINUE
|
|
END IF
|
|
KK = KK + J
|
|
20 CONTINUE
|
|
ELSE
|
|
JX = KX
|
|
DO 40, J = 1, N
|
|
IF( X( JX ).NE.ZERO )THEN
|
|
TEMP = ALPHA*X( JX )
|
|
IX = KX
|
|
DO 30, K = KK, KK + J - 1
|
|
AP( K ) = AP( K ) + X( IX )*TEMP
|
|
IX = IX + INCX
|
|
30 CONTINUE
|
|
END IF
|
|
JX = JX + INCX
|
|
KK = KK + J
|
|
40 CONTINUE
|
|
END IF
|
|
ELSE
|
|
*
|
|
* Form A when lower triangle is stored in AP.
|
|
*
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 60, J = 1, N
|
|
IF( X( J ).NE.ZERO )THEN
|
|
TEMP = ALPHA*X( J )
|
|
K = KK
|
|
DO 50, I = J, N
|
|
AP( K ) = AP( K ) + X( I )*TEMP
|
|
K = K + 1
|
|
50 CONTINUE
|
|
END IF
|
|
KK = KK + N - J + 1
|
|
60 CONTINUE
|
|
ELSE
|
|
JX = KX
|
|
DO 80, J = 1, N
|
|
IF( X( JX ).NE.ZERO )THEN
|
|
TEMP = ALPHA*X( JX )
|
|
IX = JX
|
|
DO 70, K = KK, KK + N - J
|
|
AP( K ) = AP( K ) + X( IX )*TEMP
|
|
IX = IX + INCX
|
|
70 CONTINUE
|
|
END IF
|
|
JX = JX + INCX
|
|
KK = KK + N - J + 1
|
|
80 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of DSPR .
|
|
*
|
|
END
|
|
SUBROUTINE ZHPR ( UPLO, N, ALPHA, X, INCX, AP )
|
|
* .. Scalar Arguments ..
|
|
DOUBLE PRECISION ALPHA
|
|
INTEGER INCX, N
|
|
CHARACTER*1 UPLO
|
|
* .. Array Arguments ..
|
|
COMPLEX*16 AP( * ), X( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* ZHPR performs the hermitian rank 1 operation
|
|
*
|
|
* A := alpha*x*conjg( x' ) + A,
|
|
*
|
|
* where alpha is a real scalar, x is an n element vector and A is an
|
|
* n by n hermitian matrix, supplied in packed form.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* UPLO - CHARACTER*1.
|
|
* On entry, UPLO specifies whether the upper or lower
|
|
* triangular part of the matrix A is supplied in the packed
|
|
* array AP as follows:
|
|
*
|
|
* UPLO = 'U' or 'u' The upper triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* UPLO = 'L' or 'l' The lower triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the order of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - DOUBLE PRECISION.
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* X - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
|
* Before entry, the incremented array X must contain the n
|
|
* element vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* AP - COMPLEX*16 array of DIMENSION at least
|
|
* ( ( n*( n + 1 ) )/2 ).
|
|
* Before entry with UPLO = 'U' or 'u', the array AP must
|
|
* contain the upper triangular part of the hermitian matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
|
* and a( 2, 2 ) respectively, and so on. On exit, the array
|
|
* AP is overwritten by the upper triangular part of the
|
|
* updated matrix.
|
|
* Before entry with UPLO = 'L' or 'l', the array AP must
|
|
* contain the lower triangular part of the hermitian matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
|
* and a( 3, 1 ) respectively, and so on. On exit, the array
|
|
* AP is overwritten by the lower triangular part of the
|
|
* updated matrix.
|
|
* Note that the imaginary parts of the diagonal elements need
|
|
* not be set, they are assumed to be zero, and on exit they
|
|
* are set to zero.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
COMPLEX*16 ZERO
|
|
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
|
* .. Local Scalars ..
|
|
COMPLEX*16 TEMP
|
|
INTEGER I, INFO, IX, J, JX, K, KK, KX
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC DCONJG, DBLE
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
|
|
$ .NOT.LSAME( UPLO, 'L' ) )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 5
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'ZHPR ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) )
|
|
$ RETURN
|
|
*
|
|
* Set the start point in X if the increment is not unity.
|
|
*
|
|
IF( INCX.LE.0 )THEN
|
|
KX = 1 - ( N - 1 )*INCX
|
|
ELSE IF( INCX.NE.1 )THEN
|
|
KX = 1
|
|
END IF
|
|
*
|
|
* Start the operations. In this version the elements of the array AP
|
|
* are accessed sequentially with one pass through AP.
|
|
*
|
|
KK = 1
|
|
IF( LSAME( UPLO, 'U' ) )THEN
|
|
*
|
|
* Form A when upper triangle is stored in AP.
|
|
*
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 20, J = 1, N
|
|
IF( X( J ).NE.ZERO )THEN
|
|
TEMP = ALPHA*DCONJG( X( J ) )
|
|
K = KK
|
|
DO 10, I = 1, J - 1
|
|
AP( K ) = AP( K ) + X( I )*TEMP
|
|
K = K + 1
|
|
10 CONTINUE
|
|
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) )
|
|
$ + DBLE( X( J )*TEMP )
|
|
ELSE
|
|
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) )
|
|
END IF
|
|
KK = KK + J
|
|
20 CONTINUE
|
|
ELSE
|
|
JX = KX
|
|
DO 40, J = 1, N
|
|
IF( X( JX ).NE.ZERO )THEN
|
|
TEMP = ALPHA*DCONJG( X( JX ) )
|
|
IX = KX
|
|
DO 30, K = KK, KK + J - 2
|
|
AP( K ) = AP( K ) + X( IX )*TEMP
|
|
IX = IX + INCX
|
|
30 CONTINUE
|
|
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) )
|
|
$ + DBLE( X( JX )*TEMP )
|
|
ELSE
|
|
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) )
|
|
END IF
|
|
JX = JX + INCX
|
|
KK = KK + J
|
|
40 CONTINUE
|
|
END IF
|
|
ELSE
|
|
*
|
|
* Form A when lower triangle is stored in AP.
|
|
*
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 60, J = 1, N
|
|
IF( X( J ).NE.ZERO )THEN
|
|
TEMP = ALPHA*DCONJG( X( J ) )
|
|
AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( J ) )
|
|
K = KK + 1
|
|
DO 50, I = J + 1, N
|
|
AP( K ) = AP( K ) + X( I )*TEMP
|
|
K = K + 1
|
|
50 CONTINUE
|
|
ELSE
|
|
AP( KK ) = DBLE( AP( KK ) )
|
|
END IF
|
|
KK = KK + N - J + 1
|
|
60 CONTINUE
|
|
ELSE
|
|
JX = KX
|
|
DO 80, J = 1, N
|
|
IF( X( JX ).NE.ZERO )THEN
|
|
TEMP = ALPHA*DCONJG( X( JX ) )
|
|
AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( JX ) )
|
|
IX = JX
|
|
DO 70, K = KK + 1, KK + N - J
|
|
IX = IX + INCX
|
|
AP( K ) = AP( K ) + X( IX )*TEMP
|
|
70 CONTINUE
|
|
ELSE
|
|
AP( KK ) = DBLE( AP( KK ) )
|
|
END IF
|
|
JX = JX + INCX
|
|
KK = KK + N - J + 1
|
|
80 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of ZHPR .
|
|
*
|
|
END
|
|
SUBROUTINE ZHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
|
|
* .. Scalar Arguments ..
|
|
COMPLEX*16 ALPHA
|
|
INTEGER INCX, INCY, N
|
|
CHARACTER*1 UPLO
|
|
* .. Array Arguments ..
|
|
COMPLEX*16 AP( * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* ZHPR2 performs the hermitian rank 2 operation
|
|
*
|
|
* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
|
|
*
|
|
* where alpha is a scalar, x and y are n element vectors and A is an
|
|
* n by n hermitian matrix, supplied in packed form.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* UPLO - CHARACTER*1.
|
|
* On entry, UPLO specifies whether the upper or lower
|
|
* triangular part of the matrix A is supplied in the packed
|
|
* array AP as follows:
|
|
*
|
|
* UPLO = 'U' or 'u' The upper triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* UPLO = 'L' or 'l' The lower triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the order of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - COMPLEX*16 .
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* X - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
|
* Before entry, the incremented array X must contain the n
|
|
* element vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* Y - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
|
* Before entry, the incremented array Y must contain the n
|
|
* element vector y.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCY - INTEGER.
|
|
* On entry, INCY specifies the increment for the elements of
|
|
* Y. INCY must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* AP - COMPLEX*16 array of DIMENSION at least
|
|
* ( ( n*( n + 1 ) )/2 ).
|
|
* Before entry with UPLO = 'U' or 'u', the array AP must
|
|
* contain the upper triangular part of the hermitian matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
|
* and a( 2, 2 ) respectively, and so on. On exit, the array
|
|
* AP is overwritten by the upper triangular part of the
|
|
* updated matrix.
|
|
* Before entry with UPLO = 'L' or 'l', the array AP must
|
|
* contain the lower triangular part of the hermitian matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
|
* and a( 3, 1 ) respectively, and so on. On exit, the array
|
|
* AP is overwritten by the lower triangular part of the
|
|
* updated matrix.
|
|
* Note that the imaginary parts of the diagonal elements need
|
|
* not be set, they are assumed to be zero, and on exit they
|
|
* are set to zero.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
COMPLEX*16 ZERO
|
|
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
|
* .. Local Scalars ..
|
|
COMPLEX*16 TEMP1, TEMP2
|
|
INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC DCONJG, DBLE
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
|
|
$ .NOT.LSAME( UPLO, 'L' ) )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 5
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 7
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'ZHPR2 ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
|
|
$ RETURN
|
|
*
|
|
* Set up the start points in X and Y if the increments are not both
|
|
* unity.
|
|
*
|
|
IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( N - 1 )*INCX
|
|
END IF
|
|
IF( INCY.GT.0 )THEN
|
|
KY = 1
|
|
ELSE
|
|
KY = 1 - ( N - 1 )*INCY
|
|
END IF
|
|
JX = KX
|
|
JY = KY
|
|
END IF
|
|
*
|
|
* Start the operations. In this version the elements of the array AP
|
|
* are accessed sequentially with one pass through AP.
|
|
*
|
|
KK = 1
|
|
IF( LSAME( UPLO, 'U' ) )THEN
|
|
*
|
|
* Form A when upper triangle is stored in AP.
|
|
*
|
|
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
|
DO 20, J = 1, N
|
|
IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
|
|
TEMP1 = ALPHA*DCONJG( Y( J ) )
|
|
TEMP2 = DCONJG( ALPHA*X( J ) )
|
|
K = KK
|
|
DO 10, I = 1, J - 1
|
|
AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
|
|
K = K + 1
|
|
10 CONTINUE
|
|
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) +
|
|
$ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 )
|
|
ELSE
|
|
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) )
|
|
END IF
|
|
KK = KK + J
|
|
20 CONTINUE
|
|
ELSE
|
|
DO 40, J = 1, N
|
|
IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
|
|
TEMP1 = ALPHA*DCONJG( Y( JY ) )
|
|
TEMP2 = DCONJG( ALPHA*X( JX ) )
|
|
IX = KX
|
|
IY = KY
|
|
DO 30, K = KK, KK + J - 2
|
|
AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
30 CONTINUE
|
|
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) +
|
|
$ DBLE( X( JX )*TEMP1 +
|
|
$ Y( JY )*TEMP2 )
|
|
ELSE
|
|
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) )
|
|
END IF
|
|
JX = JX + INCX
|
|
JY = JY + INCY
|
|
KK = KK + J
|
|
40 CONTINUE
|
|
END IF
|
|
ELSE
|
|
*
|
|
* Form A when lower triangle is stored in AP.
|
|
*
|
|
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
|
DO 60, J = 1, N
|
|
IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
|
|
TEMP1 = ALPHA*DCONJG( Y( J ) )
|
|
TEMP2 = DCONJG( ALPHA*X( J ) )
|
|
AP( KK ) = DBLE( AP( KK ) ) +
|
|
$ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 )
|
|
K = KK + 1
|
|
DO 50, I = J + 1, N
|
|
AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
|
|
K = K + 1
|
|
50 CONTINUE
|
|
ELSE
|
|
AP( KK ) = DBLE( AP( KK ) )
|
|
END IF
|
|
KK = KK + N - J + 1
|
|
60 CONTINUE
|
|
ELSE
|
|
DO 80, J = 1, N
|
|
IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
|
|
TEMP1 = ALPHA*DCONJG( Y( JY ) )
|
|
TEMP2 = DCONJG( ALPHA*X( JX ) )
|
|
AP( KK ) = DBLE( AP( KK ) ) +
|
|
$ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 )
|
|
IX = JX
|
|
IY = JY
|
|
DO 70, K = KK + 1, KK + N - J
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
|
|
70 CONTINUE
|
|
ELSE
|
|
AP( KK ) = DBLE( AP( KK ) )
|
|
END IF
|
|
JX = JX + INCX
|
|
JY = JY + INCY
|
|
KK = KK + N - J + 1
|
|
80 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of ZHPR2 .
|
|
*
|
|
END
|
|
SUBROUTINE ZHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
|
|
* .. Scalar Arguments ..
|
|
COMPLEX*16 ALPHA, BETA
|
|
INTEGER INCX, INCY, N
|
|
CHARACTER*1 UPLO
|
|
* .. Array Arguments ..
|
|
COMPLEX*16 AP( * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* ZHPMV performs the matrix-vector operation
|
|
*
|
|
* y := alpha*A*x + beta*y,
|
|
*
|
|
* where alpha and beta are scalars, x and y are n element vectors and
|
|
* A is an n by n hermitian matrix, supplied in packed form.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* UPLO - CHARACTER*1.
|
|
* On entry, UPLO specifies whether the upper or lower
|
|
* triangular part of the matrix A is supplied in the packed
|
|
* array AP as follows:
|
|
*
|
|
* UPLO = 'U' or 'u' The upper triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* UPLO = 'L' or 'l' The lower triangular part of A is
|
|
* supplied in AP.
|
|
*
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the order of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - COMPLEX*16 .
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* AP - COMPLEX*16 array of DIMENSION at least
|
|
* ( ( n*( n + 1 ) )/2 ).
|
|
* Before entry with UPLO = 'U' or 'u', the array AP must
|
|
* contain the upper triangular part of the hermitian matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
|
* and a( 2, 2 ) respectively, and so on.
|
|
* Before entry with UPLO = 'L' or 'l', the array AP must
|
|
* contain the lower triangular part of the hermitian matrix
|
|
* packed sequentially, column by column, so that AP( 1 )
|
|
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
|
* and a( 3, 1 ) respectively, and so on.
|
|
* Note that the imaginary parts of the diagonal elements need
|
|
* not be set and are assumed to be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* X - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
|
* Before entry, the incremented array X must contain the n
|
|
* element vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* BETA - COMPLEX*16 .
|
|
* On entry, BETA specifies the scalar beta. When BETA is
|
|
* supplied as zero then Y need not be set on input.
|
|
* Unchanged on exit.
|
|
*
|
|
* Y - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
|
* Before entry, the incremented array Y must contain the n
|
|
* element vector y. On exit, Y is overwritten by the updated
|
|
* vector y.
|
|
*
|
|
* INCY - INTEGER.
|
|
* On entry, INCY specifies the increment for the elements of
|
|
* Y. INCY must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
COMPLEX*16 ONE
|
|
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
|
|
COMPLEX*16 ZERO
|
|
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
|
* .. Local Scalars ..
|
|
COMPLEX*16 TEMP1, TEMP2
|
|
INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC DCONJG, DBLE
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
|
|
$ .NOT.LSAME( UPLO, 'L' ) )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 6
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 9
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'ZHPMV ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
|
|
$ RETURN
|
|
*
|
|
* Set up the start points in X and Y.
|
|
*
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( N - 1 )*INCX
|
|
END IF
|
|
IF( INCY.GT.0 )THEN
|
|
KY = 1
|
|
ELSE
|
|
KY = 1 - ( N - 1 )*INCY
|
|
END IF
|
|
*
|
|
* Start the operations. In this version the elements of the array AP
|
|
* are accessed sequentially with one pass through AP.
|
|
*
|
|
* First form y := beta*y.
|
|
*
|
|
IF( BETA.NE.ONE )THEN
|
|
IF( INCY.EQ.1 )THEN
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 10, I = 1, N
|
|
Y( I ) = ZERO
|
|
10 CONTINUE
|
|
ELSE
|
|
DO 20, I = 1, N
|
|
Y( I ) = BETA*Y( I )
|
|
20 CONTINUE
|
|
END IF
|
|
ELSE
|
|
IY = KY
|
|
IF( BETA.EQ.ZERO )THEN
|
|
DO 30, I = 1, N
|
|
Y( IY ) = ZERO
|
|
IY = IY + INCY
|
|
30 CONTINUE
|
|
ELSE
|
|
DO 40, I = 1, N
|
|
Y( IY ) = BETA*Y( IY )
|
|
IY = IY + INCY
|
|
40 CONTINUE
|
|
END IF
|
|
END IF
|
|
END IF
|
|
IF( ALPHA.EQ.ZERO )
|
|
$ RETURN
|
|
KK = 1
|
|
IF( LSAME( UPLO, 'U' ) )THEN
|
|
*
|
|
* Form y when AP contains the upper triangle.
|
|
*
|
|
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
|
DO 60, J = 1, N
|
|
TEMP1 = ALPHA*X( J )
|
|
TEMP2 = ZERO
|
|
K = KK
|
|
DO 50, I = 1, J - 1
|
|
Y( I ) = Y( I ) + TEMP1*AP( K )
|
|
TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I )
|
|
K = K + 1
|
|
50 CONTINUE
|
|
Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK + J - 1 ) )
|
|
$ + ALPHA*TEMP2
|
|
KK = KK + J
|
|
60 CONTINUE
|
|
ELSE
|
|
JX = KX
|
|
JY = KY
|
|
DO 80, J = 1, N
|
|
TEMP1 = ALPHA*X( JX )
|
|
TEMP2 = ZERO
|
|
IX = KX
|
|
IY = KY
|
|
DO 70, K = KK, KK + J - 2
|
|
Y( IY ) = Y( IY ) + TEMP1*AP( K )
|
|
TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX )
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
70 CONTINUE
|
|
Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK + J - 1 ) )
|
|
$ + ALPHA*TEMP2
|
|
JX = JX + INCX
|
|
JY = JY + INCY
|
|
KK = KK + J
|
|
80 CONTINUE
|
|
END IF
|
|
ELSE
|
|
*
|
|
* Form y when AP contains the lower triangle.
|
|
*
|
|
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
|
|
DO 100, J = 1, N
|
|
TEMP1 = ALPHA*X( J )
|
|
TEMP2 = ZERO
|
|
Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK ) )
|
|
K = KK + 1
|
|
DO 90, I = J + 1, N
|
|
Y( I ) = Y( I ) + TEMP1*AP( K )
|
|
TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I )
|
|
K = K + 1
|
|
90 CONTINUE
|
|
Y( J ) = Y( J ) + ALPHA*TEMP2
|
|
KK = KK + ( N - J + 1 )
|
|
100 CONTINUE
|
|
ELSE
|
|
JX = KX
|
|
JY = KY
|
|
DO 120, J = 1, N
|
|
TEMP1 = ALPHA*X( JX )
|
|
TEMP2 = ZERO
|
|
Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK ) )
|
|
IX = JX
|
|
IY = JY
|
|
DO 110, K = KK + 1, KK + N - J
|
|
IX = IX + INCX
|
|
IY = IY + INCY
|
|
Y( IY ) = Y( IY ) + TEMP1*AP( K )
|
|
TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX )
|
|
110 CONTINUE
|
|
Y( JY ) = Y( JY ) + ALPHA*TEMP2
|
|
JX = JX + INCX
|
|
JY = JY + INCY
|
|
KK = KK + ( N - J + 1 )
|
|
120 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of ZHPMV .
|
|
*
|
|
END
|
|
SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
|
|
* .. Scalar Arguments ..
|
|
COMPLEX*16 ALPHA
|
|
INTEGER INCX, INCY, LDA, M, N
|
|
* .. Array Arguments ..
|
|
COMPLEX*16 A( LDA, * ), X( * ), Y( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* ZGERC performs the rank 1 operation
|
|
*
|
|
* A := alpha*x*conjg( y' ) + A,
|
|
*
|
|
* where alpha is a scalar, x is an m element vector, y is an n element
|
|
* vector and A is an m by n matrix.
|
|
*
|
|
* Parameters
|
|
* ==========
|
|
*
|
|
* M - INTEGER.
|
|
* On entry, M specifies the number of rows of the matrix A.
|
|
* M must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* N - INTEGER.
|
|
* On entry, N specifies the number of columns of the matrix A.
|
|
* N must be at least zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* ALPHA - COMPLEX*16 .
|
|
* On entry, ALPHA specifies the scalar alpha.
|
|
* Unchanged on exit.
|
|
*
|
|
* X - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( m - 1 )*abs( INCX ) ).
|
|
* Before entry, the incremented array X must contain the m
|
|
* element vector x.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCX - INTEGER.
|
|
* On entry, INCX specifies the increment for the elements of
|
|
* X. INCX must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* Y - COMPLEX*16 array of dimension at least
|
|
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
|
* Before entry, the incremented array Y must contain the n
|
|
* element vector y.
|
|
* Unchanged on exit.
|
|
*
|
|
* INCY - INTEGER.
|
|
* On entry, INCY specifies the increment for the elements of
|
|
* Y. INCY must not be zero.
|
|
* Unchanged on exit.
|
|
*
|
|
* A - COMPLEX*16 array of DIMENSION ( LDA, n ).
|
|
* Before entry, the leading m by n part of the array A must
|
|
* contain the matrix of coefficients. On exit, A is
|
|
* overwritten by the updated matrix.
|
|
*
|
|
* LDA - INTEGER.
|
|
* On entry, LDA specifies the first dimension of A as declared
|
|
* in the calling (sub) program. LDA must be at least
|
|
* max( 1, m ).
|
|
* Unchanged on exit.
|
|
*
|
|
*
|
|
* Level 2 Blas routine.
|
|
*
|
|
* -- Written on 22-October-1986.
|
|
* Jack Dongarra, Argonne National Lab.
|
|
* Jeremy Du Croz, Nag Central Office.
|
|
* Sven Hammarling, Nag Central Office.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
*
|
|
* .. Parameters ..
|
|
COMPLEX*16 ZERO
|
|
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
|
* .. Local Scalars ..
|
|
COMPLEX*16 TEMP
|
|
INTEGER I, INFO, IX, J, JY, KX
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC DCONJG, MAX
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
IF ( M.LT.0 )THEN
|
|
INFO = 1
|
|
ELSE IF( N.LT.0 )THEN
|
|
INFO = 2
|
|
ELSE IF( INCX.EQ.0 )THEN
|
|
INFO = 5
|
|
ELSE IF( INCY.EQ.0 )THEN
|
|
INFO = 7
|
|
ELSE IF( LDA.LT.MAX( 1, M ) )THEN
|
|
INFO = 9
|
|
END IF
|
|
IF( INFO.NE.0 )THEN
|
|
CALL XERBLA( 'ZGERC ', INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible.
|
|
*
|
|
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
|
|
$ RETURN
|
|
*
|
|
* Start the operations. In this version the elements of A are
|
|
* accessed sequentially with one pass through A.
|
|
*
|
|
IF( INCY.GT.0 )THEN
|
|
JY = 1
|
|
ELSE
|
|
JY = 1 - ( N - 1 )*INCY
|
|
END IF
|
|
IF( INCX.EQ.1 )THEN
|
|
DO 20, J = 1, N
|
|
IF( Y( JY ).NE.ZERO )THEN
|
|
TEMP = ALPHA*DCONJG( Y( JY ) )
|
|
DO 10, I = 1, M
|
|
A( I, J ) = A( I, J ) + X( I )*TEMP
|
|
10 CONTINUE
|
|
END IF
|
|
JY = JY + INCY
|
|
20 CONTINUE
|
|
ELSE
|
|
IF( INCX.GT.0 )THEN
|
|
KX = 1
|
|
ELSE
|
|
KX = 1 - ( M - 1 )*INCX
|
|
END IF
|
|
DO 40, J = 1, N
|
|
IF( Y( JY ).NE.ZERO )THEN
|
|
TEMP = ALPHA*DCONJG( Y( JY ) )
|
|
IX = KX
|
|
DO 30, I = 1, M
|
|
A( I, J ) = A( I, J ) + X( IX )*TEMP
|
|
IX = IX + INCX
|
|
30 CONTINUE
|
|
END IF
|
|
JY = JY + INCY
|
|
40 CONTINUE
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of ZGERC .
|
|
*
|
|
END
|
|
subroutine drotg(da,db,c,s)
|
|
c
|
|
c construct givens plane rotation.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c
|
|
double precision da,db,c,s,roe,scale,r,z
|
|
c
|
|
roe = db
|
|
if( dabs(da) .gt. dabs(db) ) roe = da
|
|
scale = dabs(da) + dabs(db)
|
|
if( scale .ne. 0.0d0 ) go to 10
|
|
c = 1.0d0
|
|
s = 0.0d0
|
|
r = 0.0d0
|
|
z = 0.0d0
|
|
go to 20
|
|
10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2)
|
|
r = dsign(1.0d0,roe)*r
|
|
c = da/r
|
|
s = db/r
|
|
z = 1.0d0
|
|
if( dabs(da) .gt. dabs(db) ) z = s
|
|
if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c
|
|
20 da = r
|
|
db = z
|
|
return
|
|
end
|
|
subroutine drot (n,dx,incx,dy,incy,c,s)
|
|
c
|
|
c applies a plane rotation.
|
|
c jack dongarra, linpack, 3/11/78.
|
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
|
c
|
|
double precision dx(*),dy(*),dtemp,c,s
|
|
integer i,incx,incy,ix,iy,n
|
|
c
|
|
if(n.le.0)return
|
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
|
c
|
|
c code for unequal increments or equal increments not equal
|
|
c to 1
|
|
c
|
|
ix = 1
|
|
iy = 1
|
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
|
do 10 i = 1,n
|
|
dtemp = c*dx(ix) + s*dy(iy)
|
|
dy(iy) = c*dy(iy) - s*dx(ix)
|
|
dx(ix) = dtemp
|
|
ix = ix + incx
|
|
iy = iy + incy
|
|
10 continue
|
|
return
|
|
c
|
|
c code for both increments equal to 1
|
|
c
|
|
20 do 30 i = 1,n
|
|
dtemp = c*dx(i) + s*dy(i)
|
|
dy(i) = c*dy(i) - s*dx(i)
|
|
dx(i) = dtemp
|
|
30 continue
|
|
return
|
|
end
|