*
************************************************************************
*
* File of the REAL Level-2 BLAS.
* ===========================================
*
* SUBROUTINE SGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
* $ BETA, Y, INCY )
*
* SUBROUTINE SGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
* $ BETA, Y, INCY )
*
* SUBROUTINE SSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
* $ BETA, Y, INCY )
*
* SUBROUTINE SSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
* $ BETA, Y, INCY )
*
* SUBROUTINE SSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*
* SUBROUTINE STRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
* SUBROUTINE STBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
* SUBROUTINE STPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
* SUBROUTINE STRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
* SUBROUTINE STBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
* SUBROUTINE STPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
* SUBROUTINE SGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
* SUBROUTINE SSYR ( UPLO, N, ALPHA, X, INCX, A, LDA )
*
* SUBROUTINE SSPR ( UPLO, N, ALPHA, X, INCX, AP )
*
* SUBROUTINE SSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
* SUBROUTINE SSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
*
* See:
*
* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
* An extended set of Fortran Basic Linear Algebra Subprograms.
*
* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
* and Computer Science Division, Argonne National Laboratory,
* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
*
* Or
*
* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
*
************************************************************************
*
SUBROUTINE SGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
REAL ALPHA, BETA
INTEGER INCX, INCY, LDA, M, N
CHARACTER*1 TRANS
* .. Array Arguments ..
REAL A( LDA, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SGEMV 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 - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL 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 - REAL 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 - REAL .
* 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 - REAL 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 ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL 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( 'SGEMV ', 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 SGEMV .
*
END
*
************************************************************************
*
SUBROUTINE SGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
REAL ALPHA, BETA
INTEGER INCX, INCY, KL, KU, LDA, M, N
CHARACTER*1 TRANS
* .. Array Arguments ..
REAL A( LDA, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SGBMV 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 band matrix, with kl sub-diagonals and ku super-diagonals.
*
* 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.
*
* KL - INTEGER.
* On entry, KL specifies the number of sub-diagonals of the
* matrix A. KL must satisfy 0 .le. KL.
* Unchanged on exit.
*
* KU - INTEGER.
* On entry, KU specifies the number of super-diagonals of the
* matrix A. KU must satisfy 0 .le. KU.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry, the leading ( kl + ku + 1 ) by n part of the
* array A must contain the matrix of coefficients, supplied
* column by column, with the leading diagonal of the matrix in
* row ( ku + 1 ) of the array, the first super-diagonal
* starting at position 2 in row ku, the first sub-diagonal
* starting at position 1 in row ( ku + 2 ), and so on.
* Elements in the array A that do not correspond to elements
* in the band matrix (such as the top left ku by ku triangle)
* are not referenced.
* The following program segment will transfer a band matrix
* from conventional full matrix storage to band storage:
*
* DO 20, J = 1, N
* K = KU + 1 - J
* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
* A( K + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* 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
* ( kl + ku + 1 ).
* Unchanged on exit.
*
* X - REAL 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 - REAL .
* 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 - REAL 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, 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 ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP
INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY,
$ LENX, LENY
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
EXTERNAL XERBLA
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. 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( KL.LT.0 )THEN
INFO = 4
ELSE IF( KU.LT.0 )THEN
INFO = 5
ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN
INFO = 8
ELSE IF( INCX.EQ.0 )THEN
INFO = 10
ELSE IF( INCY.EQ.0 )THEN
INFO = 13
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'SGBMV ', 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 the band part of 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
KUP1 = KU + 1
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 )
K = KUP1 - J
DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL )
Y( I ) = Y( I ) + TEMP*A( K + 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
K = KUP1 - J
DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL )
Y( IY ) = Y( IY ) + TEMP*A( K + I, J )
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
IF( J.GT.KU )
$ KY = KY + INCY
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
K = KUP1 - J
DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL )
TEMP = TEMP + A( K + 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
K = KUP1 - J
DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL )
TEMP = TEMP + A( K + I, J )*X( IX )
IX = IX + INCX
110 CONTINUE
Y( JY ) = Y( JY ) + ALPHA*TEMP
JY = JY + INCY
IF( J.GT.KU )
$ KX = KX + INCX
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of SGBMV .
*
END
*
************************************************************************
*
SUBROUTINE SSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
REAL ALPHA, BETA
INTEGER INCX, INCY, LDA, N
CHARACTER*1 UPLO
* .. Array Arguments ..
REAL A( LDA, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SSYMV 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.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* 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 - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced.
* 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, n ).
* Unchanged on exit.
*
* X - REAL 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 - REAL .
* 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 - REAL 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 ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP1, TEMP2
INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
* .. 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( UPLO, 'U' ).AND.
$ .NOT.LSAME( UPLO, 'L' ) )THEN
INFO = 1
ELSE IF( N.LT.0 )THEN
INFO = 2
ELSE IF( LDA.LT.MAX( 1, N ) )THEN
INFO = 5
ELSE IF( INCX.EQ.0 )THEN
INFO = 7
ELSE IF( INCY.EQ.0 )THEN
INFO = 10
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'SSYMV ', 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 A are
* accessed sequentially with one pass through the triangular part
* of 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, 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
IF( LSAME( UPLO, 'U' ) )THEN
*
* Form y when A is stored in upper triangle.
*
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
DO 60, J = 1, N
TEMP1 = ALPHA*X( J )
TEMP2 = ZERO
DO 50, I = 1, J - 1
Y( I ) = Y( I ) + TEMP1*A( I, J )
TEMP2 = TEMP2 + A( I, J )*X( I )
50 CONTINUE
Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80, J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
IX = KX
IY = KY
DO 70, I = 1, J - 1
Y( IY ) = Y( IY ) + TEMP1*A( I, J )
TEMP2 = TEMP2 + A( I, J )*X( IX )
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y when A is stored in 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*A( J, J )
DO 90, I = J + 1, N
Y( I ) = Y( I ) + TEMP1*A( I, J )
TEMP2 = TEMP2 + A( I, J )*X( I )
90 CONTINUE
Y( J ) = Y( J ) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120, J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
Y( JY ) = Y( JY ) + TEMP1*A( J, J )
IX = JX
IY = JY
DO 110, I = J + 1, N
IX = IX + INCX
IY = IY + INCY
Y( IY ) = Y( IY ) + TEMP1*A( I, J )
TEMP2 = TEMP2 + A( I, J )*X( IX )
110 CONTINUE
Y( JY ) = Y( JY ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSYMV .
*
END
*
************************************************************************
*
SUBROUTINE SSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
REAL ALPHA, BETA
INTEGER INCX, INCY, K, LDA, N
CHARACTER*1 UPLO
* .. Array Arguments ..
REAL A( LDA, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SSBMV 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 band matrix, with k super-diagonals.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the band matrix A is being supplied as
* follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* being supplied.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* being supplied.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry, K specifies the number of super-diagonals of the
* matrix A. K must satisfy 0 .le. K.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the symmetric matrix, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer the upper
* triangular part of a symmetric band matrix from conventional
* full matrix storage to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the symmetric matrix, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer the lower
* triangular part of a symmetric band matrix from conventional
* full matrix storage to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* 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
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* 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 - REAL .
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* Y - REAL array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, 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 ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP1, TEMP2
INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
EXTERNAL XERBLA
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. 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( K.LT.0 )THEN
INFO = 3
ELSE IF( LDA.LT.( K + 1 ) )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( 'SSBMV ', 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 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, 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
IF( LSAME( UPLO, 'U' ) )THEN
*
* Form y when upper triangle of A is stored.
*
KPLUS1 = K + 1
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
DO 60, J = 1, N
TEMP1 = ALPHA*X( J )
TEMP2 = ZERO
L = KPLUS1 - J
DO 50, I = MAX( 1, J - K ), J - 1
Y( I ) = Y( I ) + TEMP1*A( L + I, J )
TEMP2 = TEMP2 + A( L + I, J )*X( I )
50 CONTINUE
Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80, J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
IX = KX
IY = KY
L = KPLUS1 - J
DO 70, I = MAX( 1, J - K ), J - 1
Y( IY ) = Y( IY ) + TEMP1*A( L + I, J )
TEMP2 = TEMP2 + A( L + I, J )*X( IX )
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
IF( J.GT.K )THEN
KX = KX + INCX
KY = KY + INCY
END IF
80 CONTINUE
END IF
ELSE
*
* Form y when lower triangle of A is stored.
*
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*A( 1, J )
L = 1 - J
DO 90, I = J + 1, MIN( N, J + K )
Y( I ) = Y( I ) + TEMP1*A( L + I, J )
TEMP2 = TEMP2 + A( L + I, J )*X( I )
90 CONTINUE
Y( J ) = Y( J ) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120, J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
Y( JY ) = Y( JY ) + TEMP1*A( 1, J )
L = 1 - J
IX = JX
IY = JY
DO 110, I = J + 1, MIN( N, J + K )
IX = IX + INCX
IY = IY + INCY
Y( IY ) = Y( IY ) + TEMP1*A( L + I, J )
TEMP2 = TEMP2 + A( L + I, J )*X( IX )
110 CONTINUE
Y( JY ) = Y( JY ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSBMV .
*
END
*
************************************************************************
*
SUBROUTINE SSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
* .. Scalar Arguments ..
REAL ALPHA, BETA
INTEGER INCX, INCY, N
CHARACTER*1 UPLO
* .. Array Arguments ..
REAL AP( * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SSPMV 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 - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* AP - REAL 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 - REAL 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 - REAL .
* 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 - REAL 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 ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL 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( 'SSPMV ', 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 SSPMV .
*
END
*
************************************************************************
*
SUBROUTINE STRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, LDA, N
CHARACTER*1 DIAG, TRANS, UPLO
* .. Array Arguments ..
REAL A( LDA, * ), X( * )
* ..
*
* Purpose
* =======
*
* STRMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' or 'u' A is an upper triangular matrix.
*
* UPLO = 'L' or 'l' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
*
* DIAG = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular matrix and the strictly lower triangular part of
* A is not referenced.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular matrix and the strictly upper triangular part of
* A is not referenced.
* Note that when DIAG = 'U' or 'u', the diagonal elements of
* A are not referenced either, but are assumed to be unity.
* 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, n ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP
INTEGER I, INFO, IX, J, JX, KX
LOGICAL NOUNIT
* .. 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( UPLO , 'U' ).AND.
$ .NOT.LSAME( UPLO , 'L' ) )THEN
INFO = 1
ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
$ .NOT.LSAME( TRANS, 'T' ).AND.
$ .NOT.LSAME( TRANS, 'C' ) )THEN
INFO = 2
ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
$ .NOT.LSAME( DIAG , 'N' ) )THEN
INFO = 3
ELSE IF( N.LT.0 )THEN
INFO = 4
ELSE IF( LDA.LT.MAX( 1, N ) )THEN
INFO = 6
ELSE IF( INCX.EQ.0 )THEN
INFO = 8
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'STRMV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
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 A are
* accessed sequentially with one pass through A.
*
IF( LSAME( TRANS, 'N' ) )THEN
*
* Form x := A*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
IF( INCX.EQ.1 )THEN
DO 20, J = 1, N
IF( X( J ).NE.ZERO )THEN
TEMP = X( J )
DO 10, I = 1, J - 1
X( I ) = X( I ) + TEMP*A( I, J )
10 CONTINUE
IF( NOUNIT )
$ X( J ) = X( J )*A( J, J )
END IF
20 CONTINUE
ELSE
JX = KX
DO 40, J = 1, N
IF( X( JX ).NE.ZERO )THEN
TEMP = X( JX )
IX = KX
DO 30, I = 1, J - 1
X( IX ) = X( IX ) + TEMP*A( I, J )
IX = IX + INCX
30 CONTINUE
IF( NOUNIT )
$ X( JX ) = X( JX )*A( J, J )
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
IF( INCX.EQ.1 )THEN
DO 60, J = N, 1, -1
IF( X( J ).NE.ZERO )THEN
TEMP = X( J )
DO 50, I = N, J + 1, -1
X( I ) = X( I ) + TEMP*A( I, J )
50 CONTINUE
IF( NOUNIT )
$ X( J ) = X( J )*A( J, J )
END IF
60 CONTINUE
ELSE
KX = KX + ( N - 1 )*INCX
JX = KX
DO 80, J = N, 1, -1
IF( X( JX ).NE.ZERO )THEN
TEMP = X( JX )
IX = KX
DO 70, I = N, J + 1, -1
X( IX ) = X( IX ) + TEMP*A( I, J )
IX = IX - INCX
70 CONTINUE
IF( NOUNIT )
$ X( JX ) = X( JX )*A( J, J )
END IF
JX = JX - INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A'*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
IF( INCX.EQ.1 )THEN
DO 100, J = N, 1, -1
TEMP = X( J )
IF( NOUNIT )
$ TEMP = TEMP*A( J, J )
DO 90, I = J - 1, 1, -1
TEMP = TEMP + A( I, J )*X( I )
90 CONTINUE
X( J ) = TEMP
100 CONTINUE
ELSE
JX = KX + ( N - 1 )*INCX
DO 120, J = N, 1, -1
TEMP = X( JX )
IX = JX
IF( NOUNIT )
$ TEMP = TEMP*A( J, J )
DO 110, I = J - 1, 1, -1
IX = IX - INCX
TEMP = TEMP + A( I, J )*X( IX )
110 CONTINUE
X( JX ) = TEMP
JX = JX - INCX
120 CONTINUE
END IF
ELSE
IF( INCX.EQ.1 )THEN
DO 140, J = 1, N
TEMP = X( J )
IF( NOUNIT )
$ TEMP = TEMP*A( J, J )
DO 130, I = J + 1, N
TEMP = TEMP + A( I, J )*X( I )
130 CONTINUE
X( J ) = TEMP
140 CONTINUE
ELSE
JX = KX
DO 160, J = 1, N
TEMP = X( JX )
IX = JX
IF( NOUNIT )
$ TEMP = TEMP*A( J, J )
DO 150, I = J + 1, N
IX = IX + INCX
TEMP = TEMP + A( I, J )*X( IX )
150 CONTINUE
X( JX ) = TEMP
JX = JX + INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STRMV .
*
END
*
************************************************************************
*
SUBROUTINE STBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, K, LDA, N
CHARACTER*1 DIAG, TRANS, UPLO
* .. Array Arguments ..
REAL A( LDA, * ), X( * )
* ..
*
* Purpose
* =======
*
* STBMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular band matrix, with ( k + 1 ) diagonals.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' or 'u' A is an upper triangular matrix.
*
* UPLO = 'L' or 'l' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
*
* DIAG = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with UPLO = 'U' or 'u', K specifies the number of
* super-diagonals of the matrix A.
* On entry with UPLO = 'L' or 'l', K specifies the number of
* sub-diagonals of the matrix A.
* K must satisfy 0 .le. K.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer an upper
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer a lower
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Note that when DIAG = 'U' or 'u' the elements of the array A
* corresponding to the diagonal elements of the matrix are not
* referenced, but are assumed to be unity.
* 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
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP
INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
LOGICAL NOUNIT
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
EXTERNAL XERBLA
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF ( .NOT.LSAME( UPLO , 'U' ).AND.
$ .NOT.LSAME( UPLO , 'L' ) )THEN
INFO = 1
ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
$ .NOT.LSAME( TRANS, 'T' ).AND.
$ .NOT.LSAME( TRANS, 'C' ) )THEN
INFO = 2
ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
$ .NOT.LSAME( DIAG , 'N' ) )THEN
INFO = 3
ELSE IF( N.LT.0 )THEN
INFO = 4
ELSE IF( K.LT.0 )THEN
INFO = 5
ELSE IF( LDA.LT.( K + 1 ) )THEN
INFO = 7
ELSE IF( INCX.EQ.0 )THEN
INFO = 9
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'STBMV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
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 A are
* accessed sequentially with one pass through A.
*
IF( LSAME( TRANS, 'N' ) )THEN
*
* Form x := A*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
KPLUS1 = K + 1
IF( INCX.EQ.1 )THEN
DO 20, J = 1, N
IF( X( J ).NE.ZERO )THEN
TEMP = X( J )
L = KPLUS1 - J
DO 10, I = MAX( 1, J - K ), J - 1
X( I ) = X( I ) + TEMP*A( L + I, J )
10 CONTINUE
IF( NOUNIT )
$ X( J ) = X( J )*A( KPLUS1, J )
END IF
20 CONTINUE
ELSE
JX = KX
DO 40, J = 1, N
IF( X( JX ).NE.ZERO )THEN
TEMP = X( JX )
IX = KX
L = KPLUS1 - J
DO 30, I = MAX( 1, J - K ), J - 1
X( IX ) = X( IX ) + TEMP*A( L + I, J )
IX = IX + INCX
30 CONTINUE
IF( NOUNIT )
$ X( JX ) = X( JX )*A( KPLUS1, J )
END IF
JX = JX + INCX
IF( J.GT.K )
$ KX = KX + INCX
40 CONTINUE
END IF
ELSE
IF( INCX.EQ.1 )THEN
DO 60, J = N, 1, -1
IF( X( J ).NE.ZERO )THEN
TEMP = X( J )
L = 1 - J
DO 50, I = MIN( N, J + K ), J + 1, -1
X( I ) = X( I ) + TEMP*A( L + I, J )
50 CONTINUE
IF( NOUNIT )
$ X( J ) = X( J )*A( 1, J )
END IF
60 CONTINUE
ELSE
KX = KX + ( N - 1 )*INCX
JX = KX
DO 80, J = N, 1, -1
IF( X( JX ).NE.ZERO )THEN
TEMP = X( JX )
IX = KX
L = 1 - J
DO 70, I = MIN( N, J + K ), J + 1, -1
X( IX ) = X( IX ) + TEMP*A( L + I, J )
IX = IX - INCX
70 CONTINUE
IF( NOUNIT )
$ X( JX ) = X( JX )*A( 1, J )
END IF
JX = JX - INCX
IF( ( N - J ).GE.K )
$ KX = KX - INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A'*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
KPLUS1 = K + 1
IF( INCX.EQ.1 )THEN
DO 100, J = N, 1, -1
TEMP = X( J )
L = KPLUS1 - J
IF( NOUNIT )
$ TEMP = TEMP*A( KPLUS1, J )
DO 90, I = J - 1, MAX( 1, J - K ), -1
TEMP = TEMP + A( L + I, J )*X( I )
90 CONTINUE
X( J ) = TEMP
100 CONTINUE
ELSE
KX = KX + ( N - 1 )*INCX
JX = KX
DO 120, J = N, 1, -1
TEMP = X( JX )
KX = KX - INCX
IX = KX
L = KPLUS1 - J
IF( NOUNIT )
$ TEMP = TEMP*A( KPLUS1, J )
DO 110, I = J - 1, MAX( 1, J - K ), -1
TEMP = TEMP + A( L + I, J )*X( IX )
IX = IX - INCX
110 CONTINUE
X( JX ) = TEMP
JX = JX - INCX
120 CONTINUE
END IF
ELSE
IF( INCX.EQ.1 )THEN
DO 140, J = 1, N
TEMP = X( J )
L = 1 - J
IF( NOUNIT )
$ TEMP = TEMP*A( 1, J )
DO 130, I = J + 1, MIN( N, J + K )
TEMP = TEMP + A( L + I, J )*X( I )
130 CONTINUE
X( J ) = TEMP
140 CONTINUE
ELSE
JX = KX
DO 160, J = 1, N
TEMP = X( JX )
KX = KX + INCX
IX = KX
L = 1 - J
IF( NOUNIT )
$ TEMP = TEMP*A( 1, J )
DO 150, I = J + 1, MIN( N, J + K )
TEMP = TEMP + A( L + I, J )*X( IX )
IX = IX + INCX
150 CONTINUE
X( JX ) = TEMP
JX = JX + INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STBMV .
*
END
*
************************************************************************
*
SUBROUTINE STPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
CHARACTER*1 DIAG, TRANS, UPLO
* .. Array Arguments ..
REAL AP( * ), X( * )
* ..
*
* Purpose
* =======
*
* STPMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular matrix, supplied in packed form.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' or 'u' A is an upper triangular matrix.
*
* UPLO = 'L' or 'l' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
*
* DIAG = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular 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 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 when DIAG = 'U' or 'u', the diagonal elements of
* A are not referenced, but are assumed to be unity.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP
INTEGER I, INFO, IX, J, JX, K, KK, KX
LOGICAL NOUNIT
* .. 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( .NOT.LSAME( TRANS, 'N' ).AND.
$ .NOT.LSAME( TRANS, 'T' ).AND.
$ .NOT.LSAME( TRANS, 'C' ) )THEN
INFO = 2
ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
$ .NOT.LSAME( DIAG , 'N' ) )THEN
INFO = 3
ELSE IF( N.LT.0 )THEN
INFO = 4
ELSE IF( INCX.EQ.0 )THEN
INFO = 7
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'STPMV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
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 AP are
* accessed sequentially with one pass through AP.
*
IF( LSAME( TRANS, 'N' ) )THEN
*
* Form x:= A*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
KK =1
IF( INCX.EQ.1 )THEN
DO 20, J = 1, N
IF( X( J ).NE.ZERO )THEN
TEMP = X( J )
K = KK
DO 10, I = 1, J - 1
X( I ) = X( I ) + TEMP*AP( K )
K = K + 1
10 CONTINUE
IF( NOUNIT )
$ X( J ) = X( J )*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 = X( JX )
IX = KX
DO 30, K = KK, KK + J - 2
X( IX ) = X( IX ) + TEMP*AP( K )
IX = IX + INCX
30 CONTINUE
IF( NOUNIT )
$ X( JX ) = X( JX )*AP( KK + J - 1 )
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
KK = ( N*( N + 1 ) )/2
IF( INCX.EQ.1 )THEN
DO 60, J = N, 1, -1
IF( X( J ).NE.ZERO )THEN
TEMP = X( J )
K = KK
DO 50, I = N, J + 1, -1
X( I ) = X( I ) + TEMP*AP( K )
K = K - 1
50 CONTINUE
IF( NOUNIT )
$ X( J ) = X( J )*AP( KK - N + J )
END IF
KK = KK - ( N - J + 1 )
60 CONTINUE
ELSE
KX = KX + ( N - 1 )*INCX
JX = KX
DO 80, J = N, 1, -1
IF( X( JX ).NE.ZERO )THEN
TEMP = X( JX )
IX = KX
DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1
X( IX ) = X( IX ) + TEMP*AP( K )
IX = IX - INCX
70 CONTINUE
IF( NOUNIT )
$ X( JX ) = X( JX )*AP( KK - N + J )
END IF
JX = JX - INCX
KK = KK - ( N - J + 1 )
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A'*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
KK = ( N*( N + 1 ) )/2
IF( INCX.EQ.1 )THEN
DO 100, J = N, 1, -1
TEMP = X( J )
IF( NOUNIT )
$ TEMP = TEMP*AP( KK )
K = KK - 1
DO 90, I = J - 1, 1, -1
TEMP = TEMP + AP( K )*X( I )
K = K - 1
90 CONTINUE
X( J ) = TEMP
KK = KK - J
100 CONTINUE
ELSE
JX = KX + ( N - 1 )*INCX
DO 120, J = N, 1, -1
TEMP = X( JX )
IX = JX
IF( NOUNIT )
$ TEMP = TEMP*AP( KK )
DO 110, K = KK - 1, KK - J + 1, -1
IX = IX - INCX
TEMP = TEMP + AP( K )*X( IX )
110 CONTINUE
X( JX ) = TEMP
JX = JX - INCX
KK = KK - J
120 CONTINUE
END IF
ELSE
KK = 1
IF( INCX.EQ.1 )THEN
DO 140, J = 1, N
TEMP = X( J )
IF( NOUNIT )
$ TEMP = TEMP*AP( KK )
K = KK + 1
DO 130, I = J + 1, N
TEMP = TEMP + AP( K )*X( I )
K = K + 1
130 CONTINUE
X( J ) = TEMP
KK = KK + ( N - J + 1 )
140 CONTINUE
ELSE
JX = KX
DO 160, J = 1, N
TEMP = X( JX )
IX = JX
IF( NOUNIT )
$ TEMP = TEMP*AP( KK )
DO 150, K = KK + 1, KK + N - J
IX = IX + INCX
TEMP = TEMP + AP( K )*X( IX )
150 CONTINUE
X( JX ) = TEMP
JX = JX + INCX
KK = KK + ( N - J + 1 )
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STPMV .
*
END
*
************************************************************************
*
SUBROUTINE STRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, LDA, N
CHARACTER*1 DIAG, TRANS, UPLO
* .. Array Arguments ..
REAL A( LDA, * ), X( * )
* ..
*
* Purpose
* =======
*
* STRSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular matrix.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' or 'u' A is an upper triangular matrix.
*
* UPLO = 'L' or 'l' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
*
* DIAG = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular matrix and the strictly lower triangular part of
* A is not referenced.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular matrix and the strictly upper triangular part of
* A is not referenced.
* Note that when DIAG = 'U' or 'u', the diagonal elements of
* A are not referenced either, but are assumed to be unity.
* 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, n ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP
INTEGER I, INFO, IX, J, JX, KX
LOGICAL NOUNIT
* .. 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( UPLO , 'U' ).AND.
$ .NOT.LSAME( UPLO , 'L' ) )THEN
INFO = 1
ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
$ .NOT.LSAME( TRANS, 'T' ).AND.
$ .NOT.LSAME( TRANS, 'C' ) )THEN
INFO = 2
ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
$ .NOT.LSAME( DIAG , 'N' ) )THEN
INFO = 3
ELSE IF( N.LT.0 )THEN
INFO = 4
ELSE IF( LDA.LT.MAX( 1, N ) )THEN
INFO = 6
ELSE IF( INCX.EQ.0 )THEN
INFO = 8
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'STRSV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
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 A are
* accessed sequentially with one pass through A.
*
IF( LSAME( TRANS, 'N' ) )THEN
*
* Form x := inv( A )*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
IF( INCX.EQ.1 )THEN
DO 20, J = N, 1, -1
IF( X( J ).NE.ZERO )THEN
IF( NOUNIT )
$ X( J ) = X( J )/A( J, J )
TEMP = X( J )
DO 10, I = J - 1, 1, -1
X( I ) = X( I ) - TEMP*A( I, J )
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX + ( N - 1 )*INCX
DO 40, J = N, 1, -1
IF( X( JX ).NE.ZERO )THEN
IF( NOUNIT )
$ X( JX ) = X( JX )/A( J, J )
TEMP = X( JX )
IX = JX
DO 30, I = J - 1, 1, -1
IX = IX - INCX
X( IX ) = X( IX ) - TEMP*A( I, J )
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF( INCX.EQ.1 )THEN
DO 60, J = 1, N
IF( X( J ).NE.ZERO )THEN
IF( NOUNIT )
$ X( J ) = X( J )/A( J, J )
TEMP = X( J )
DO 50, I = J + 1, N
X( I ) = X( I ) - TEMP*A( I, J )
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80, J = 1, N
IF( X( JX ).NE.ZERO )THEN
IF( NOUNIT )
$ X( JX ) = X( JX )/A( J, J )
TEMP = X( JX )
IX = JX
DO 70, I = J + 1, N
IX = IX + INCX
X( IX ) = X( IX ) - TEMP*A( I, J )
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A' )*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
IF( INCX.EQ.1 )THEN
DO 100, J = 1, N
TEMP = X( J )
DO 90, I = 1, J - 1
TEMP = TEMP - A( I, J )*X( I )
90 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/A( J, J )
X( J ) = TEMP
100 CONTINUE
ELSE
JX = KX
DO 120, J = 1, N
TEMP = X( JX )
IX = KX
DO 110, I = 1, J - 1
TEMP = TEMP - A( I, J )*X( IX )
IX = IX + INCX
110 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/A( J, J )
X( JX ) = TEMP
JX = JX + INCX
120 CONTINUE
END IF
ELSE
IF( INCX.EQ.1 )THEN
DO 140, J = N, 1, -1
TEMP = X( J )
DO 130, I = N, J + 1, -1
TEMP = TEMP - A( I, J )*X( I )
130 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/A( J, J )
X( J ) = TEMP
140 CONTINUE
ELSE
KX = KX + ( N - 1 )*INCX
JX = KX
DO 160, J = N, 1, -1
TEMP = X( JX )
IX = KX
DO 150, I = N, J + 1, -1
TEMP = TEMP - A( I, J )*X( IX )
IX = IX - INCX
150 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/A( J, J )
X( JX ) = TEMP
JX = JX - INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STRSV .
*
END
*
************************************************************************
*
SUBROUTINE STBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, K, LDA, N
CHARACTER*1 DIAG, TRANS, UPLO
* .. Array Arguments ..
REAL A( LDA, * ), X( * )
* ..
*
* Purpose
* =======
*
* STBSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular band matrix, with ( k + 1 )
* diagonals.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' or 'u' A is an upper triangular matrix.
*
* UPLO = 'L' or 'l' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
*
* DIAG = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with UPLO = 'U' or 'u', K specifies the number of
* super-diagonals of the matrix A.
* On entry with UPLO = 'L' or 'l', K specifies the number of
* sub-diagonals of the matrix A.
* K must satisfy 0 .le. K.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer an upper
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer a lower
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Note that when DIAG = 'U' or 'u' the elements of the array A
* corresponding to the diagonal elements of the matrix are not
* referenced, but are assumed to be unity.
* 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
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP
INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
LOGICAL NOUNIT
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
EXTERNAL XERBLA
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF ( .NOT.LSAME( UPLO , 'U' ).AND.
$ .NOT.LSAME( UPLO , 'L' ) )THEN
INFO = 1
ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
$ .NOT.LSAME( TRANS, 'T' ).AND.
$ .NOT.LSAME( TRANS, 'C' ) )THEN
INFO = 2
ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
$ .NOT.LSAME( DIAG , 'N' ) )THEN
INFO = 3
ELSE IF( N.LT.0 )THEN
INFO = 4
ELSE IF( K.LT.0 )THEN
INFO = 5
ELSE IF( LDA.LT.( K + 1 ) )THEN
INFO = 7
ELSE IF( INCX.EQ.0 )THEN
INFO = 9
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'STBSV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
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 A are
* accessed by sequentially with one pass through A.
*
IF( LSAME( TRANS, 'N' ) )THEN
*
* Form x := inv( A )*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
KPLUS1 = K + 1
IF( INCX.EQ.1 )THEN
DO 20, J = N, 1, -1
IF( X( J ).NE.ZERO )THEN
L = KPLUS1 - J
IF( NOUNIT )
$ X( J ) = X( J )/A( KPLUS1, J )
TEMP = X( J )
DO 10, I = J - 1, MAX( 1, J - K ), -1
X( I ) = X( I ) - TEMP*A( L + I, J )
10 CONTINUE
END IF
20 CONTINUE
ELSE
KX = KX + ( N - 1 )*INCX
JX = KX
DO 40, J = N, 1, -1
KX = KX - INCX
IF( X( JX ).NE.ZERO )THEN
IX = KX
L = KPLUS1 - J
IF( NOUNIT )
$ X( JX ) = X( JX )/A( KPLUS1, J )
TEMP = X( JX )
DO 30, I = J - 1, MAX( 1, J - K ), -1
X( IX ) = X( IX ) - TEMP*A( L + I, J )
IX = IX - INCX
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF( INCX.EQ.1 )THEN
DO 60, J = 1, N
IF( X( J ).NE.ZERO )THEN
L = 1 - J
IF( NOUNIT )
$ X( J ) = X( J )/A( 1, J )
TEMP = X( J )
DO 50, I = J + 1, MIN( N, J + K )
X( I ) = X( I ) - TEMP*A( L + I, J )
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80, J = 1, N
KX = KX + INCX
IF( X( JX ).NE.ZERO )THEN
IX = KX
L = 1 - J
IF( NOUNIT )
$ X( JX ) = X( JX )/A( 1, J )
TEMP = X( JX )
DO 70, I = J + 1, MIN( N, J + K )
X( IX ) = X( IX ) - TEMP*A( L + I, J )
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A')*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
KPLUS1 = K + 1
IF( INCX.EQ.1 )THEN
DO 100, J = 1, N
TEMP = X( J )
L = KPLUS1 - J
DO 90, I = MAX( 1, J - K ), J - 1
TEMP = TEMP - A( L + I, J )*X( I )
90 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/A( KPLUS1, J )
X( J ) = TEMP
100 CONTINUE
ELSE
JX = KX
DO 120, J = 1, N
TEMP = X( JX )
IX = KX
L = KPLUS1 - J
DO 110, I = MAX( 1, J - K ), J - 1
TEMP = TEMP - A( L + I, J )*X( IX )
IX = IX + INCX
110 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/A( KPLUS1, J )
X( JX ) = TEMP
JX = JX + INCX
IF( J.GT.K )
$ KX = KX + INCX
120 CONTINUE
END IF
ELSE
IF( INCX.EQ.1 )THEN
DO 140, J = N, 1, -1
TEMP = X( J )
L = 1 - J
DO 130, I = MIN( N, J + K ), J + 1, -1
TEMP = TEMP - A( L + I, J )*X( I )
130 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/A( 1, J )
X( J ) = TEMP
140 CONTINUE
ELSE
KX = KX + ( N - 1 )*INCX
JX = KX
DO 160, J = N, 1, -1
TEMP = X( JX )
IX = KX
L = 1 - J
DO 150, I = MIN( N, J + K ), J + 1, -1
TEMP = TEMP - A( L + I, J )*X( IX )
IX = IX - INCX
150 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/A( 1, J )
X( JX ) = TEMP
JX = JX - INCX
IF( ( N - J ).GE.K )
$ KX = KX - INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STBSV .
*
END
*
************************************************************************
*
SUBROUTINE STPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
CHARACTER*1 DIAG, TRANS, UPLO
* .. Array Arguments ..
REAL AP( * ), X( * )
* ..
*
* Purpose
* =======
*
* STPSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular matrix, supplied in packed form.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' or 'u' A is an upper triangular matrix.
*
* UPLO = 'L' or 'l' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
*
* DIAG = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular 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 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 when DIAG = 'U' or 'u', the diagonal elements of
* A are not referenced, but are assumed to be unity.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP
INTEGER I, INFO, IX, J, JX, K, KK, KX
LOGICAL NOUNIT
* .. 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( .NOT.LSAME( TRANS, 'N' ).AND.
$ .NOT.LSAME( TRANS, 'T' ).AND.
$ .NOT.LSAME( TRANS, 'C' ) )THEN
INFO = 2
ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
$ .NOT.LSAME( DIAG , 'N' ) )THEN
INFO = 3
ELSE IF( N.LT.0 )THEN
INFO = 4
ELSE IF( INCX.EQ.0 )THEN
INFO = 7
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'STPSV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
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 AP are
* accessed sequentially with one pass through AP.
*
IF( LSAME( TRANS, 'N' ) )THEN
*
* Form x := inv( A )*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
KK = ( N*( N + 1 ) )/2
IF( INCX.EQ.1 )THEN
DO 20, J = N, 1, -1
IF( X( J ).NE.ZERO )THEN
IF( NOUNIT )
$ X( J ) = X( J )/AP( KK )
TEMP = X( J )
K = KK - 1
DO 10, I = J - 1, 1, -1
X( I ) = X( I ) - TEMP*AP( K )
K = K - 1
10 CONTINUE
END IF
KK = KK - J
20 CONTINUE
ELSE
JX = KX + ( N - 1 )*INCX
DO 40, J = N, 1, -1
IF( X( JX ).NE.ZERO )THEN
IF( NOUNIT )
$ X( JX ) = X( JX )/AP( KK )
TEMP = X( JX )
IX = JX
DO 30, K = KK - 1, KK - J + 1, -1
IX = IX - INCX
X( IX ) = X( IX ) - TEMP*AP( K )
30 CONTINUE
END IF
JX = JX - INCX
KK = KK - J
40 CONTINUE
END IF
ELSE
KK = 1
IF( INCX.EQ.1 )THEN
DO 60, J = 1, N
IF( X( J ).NE.ZERO )THEN
IF( NOUNIT )
$ X( J ) = X( J )/AP( KK )
TEMP = X( J )
K = KK + 1
DO 50, I = J + 1, N
X( I ) = X( I ) - TEMP*AP( K )
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
IF( NOUNIT )
$ X( JX ) = X( JX )/AP( KK )
TEMP = X( JX )
IX = JX
DO 70, K = KK + 1, KK + N - J
IX = IX + INCX
X( IX ) = X( IX ) - TEMP*AP( K )
70 CONTINUE
END IF
JX = JX + INCX
KK = KK + ( N - J + 1 )
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A' )*x.
*
IF( LSAME( UPLO, 'U' ) )THEN
KK = 1
IF( INCX.EQ.1 )THEN
DO 100, J = 1, N
TEMP = X( J )
K = KK
DO 90, I = 1, J - 1
TEMP = TEMP - AP( K )*X( I )
K = K + 1
90 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/AP( KK + J - 1 )
X( J ) = TEMP
KK = KK + J
100 CONTINUE
ELSE
JX = KX
DO 120, J = 1, N
TEMP = X( JX )
IX = KX
DO 110, K = KK, KK + J - 2
TEMP = TEMP - AP( K )*X( IX )
IX = IX + INCX
110 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/AP( KK + J - 1 )
X( JX ) = TEMP
JX = JX + INCX
KK = KK + J
120 CONTINUE
END IF
ELSE
KK = ( N*( N + 1 ) )/2
IF( INCX.EQ.1 )THEN
DO 140, J = N, 1, -1
TEMP = X( J )
K = KK
DO 130, I = N, J + 1, -1
TEMP = TEMP - AP( K )*X( I )
K = K - 1
130 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/AP( KK - N + J )
X( J ) = TEMP
KK = KK - ( N - J + 1 )
140 CONTINUE
ELSE
KX = KX + ( N - 1 )*INCX
JX = KX
DO 160, J = N, 1, -1
TEMP = X( JX )
IX = KX
DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1
TEMP = TEMP - AP( K )*X( IX )
IX = IX - INCX
150 CONTINUE
IF( NOUNIT )
$ TEMP = TEMP/AP( KK - N + J )
X( JX ) = TEMP
JX = JX - INCX
KK = KK - (N - J + 1 )
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STPSV .
*
END
*
************************************************************************
*
SUBROUTINE SGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX, INCY, LDA, M, N
* .. Array Arguments ..
REAL A( LDA, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SGER 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 - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL 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 - REAL 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 - REAL 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL 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( 'SGER ', 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 SGER .
*
END
*
************************************************************************
*
SUBROUTINE SSYR ( UPLO, N, ALPHA, X, INCX, A, LDA )
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX, LDA, N
CHARACTER*1 UPLO
* .. Array Arguments ..
REAL A( LDA, * ), X( * )
* ..
*
* Purpose
* =======
*
* SSYR 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.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* 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 - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL 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.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced. On exit, the
* upper triangular part of the array A is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced. On exit, the
* lower triangular part of the array A is overwritten by the
* lower triangular part of 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, n ).
* 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP
INTEGER I, INFO, IX, J, JX, KX
* .. 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( 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( LDA.LT.MAX( 1, N ) )THEN
INFO = 7
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'SSYR ', 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 A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF( LSAME( UPLO, 'U' ) )THEN
*
* Form A when A is stored in upper triangle.
*
IF( INCX.EQ.1 )THEN
DO 20, J = 1, N
IF( X( J ).NE.ZERO )THEN
TEMP = ALPHA*X( J )
DO 10, I = 1, J
A( I, J ) = A( I, J ) + X( I )*TEMP
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX
DO 40, J = 1, N
IF( X( JX ).NE.ZERO )THEN
TEMP = ALPHA*X( JX )
IX = KX
DO 30, I = 1, J
A( I, J ) = A( I, J ) + X( IX )*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in lower triangle.
*
IF( INCX.EQ.1 )THEN
DO 60, J = 1, N
IF( X( J ).NE.ZERO )THEN
TEMP = ALPHA*X( J )
DO 50, I = J, N
A( I, J ) = A( I, J ) + X( I )*TEMP
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80, J = 1, N
IF( X( JX ).NE.ZERO )THEN
TEMP = ALPHA*X( JX )
IX = JX
DO 70, I = J, N
A( I, J ) = A( I, J ) + X( IX )*TEMP
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSYR .
*
END
*
************************************************************************
*
SUBROUTINE SSPR ( UPLO, N, ALPHA, X, INCX, AP )
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX, N
CHARACTER*1 UPLO
* .. Array Arguments ..
REAL AP( * ), X( * )
* ..
*
* Purpose
* =======
*
* SSPR 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 - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL 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 - REAL 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL 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( 'SSPR ', 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 SSPR .
*
END
*
************************************************************************
*
SUBROUTINE SSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX, INCY, LDA, N
CHARACTER*1 UPLO
* .. Array Arguments ..
REAL A( LDA, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SSYR2 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.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* 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 - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL 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 - REAL 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 - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced. On exit, the
* upper triangular part of the array A is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced. On exit, the
* lower triangular part of the array A is overwritten by the
* lower triangular part of 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, n ).
* 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL TEMP1, TEMP2
INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
* .. 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( 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
ELSE IF( LDA.LT.MAX( 1, N ) )THEN
INFO = 9
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'SSYR2 ', 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 A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF( LSAME( UPLO, 'U' ) )THEN
*
* Form A when A is stored in the upper triangle.
*
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 )
DO 10, I = 1, J
A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2
10 CONTINUE
END IF
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, I = 1, J
A( I, J ) = A( I, J ) + X( IX )*TEMP1
$ + Y( IY )*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in the lower triangle.
*
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 )
DO 50, I = J, N
A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2
50 CONTINUE
END IF
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, I = J, N
A( I, J ) = A( I, J ) + X( IX )*TEMP1
$ + Y( IY )*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSYR2 .
*
END
*
************************************************************************
*
SUBROUTINE SSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX, INCY, N
CHARACTER*1 UPLO
* .. Array Arguments ..
REAL AP( * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SSPR2 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 - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL 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 - REAL 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 - REAL 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* .. Local Scalars ..
REAL 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( 'SSPR2 ', 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 SSPR2 .
*
END
LOGICAL FUNCTION LSAME ( CA, CB )
* .. Scalar Arguments ..
CHARACTER*1 CA, CB
* ..
*
* Purpose
* =======
*
* LSAME tests if CA is the same letter as CB regardless of case.
* CB is assumed to be an upper case letter. LSAME returns .TRUE. if
* CA is either the same as CB or the equivalent lower case letter.
*
* N.B. This version of the routine is only correct for ASCII code.
* Installers must modify the routine for other character-codes.
*
* For EBCDIC systems the constant IOFF must be changed to -64.
* For CDC systems using 6-12 bit representations, the system-
* specific code in comments must be activated.
*
* Parameters
* ==========
*
* CA - CHARACTER*1
* CB - CHARACTER*1
* On entry, CA and CB specify characters to be compared.
* Unchanged on exit.
*
*
* Auxiliary routine for Level 2 Blas.
*
* -- Written on 20-July-1986
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, Nag Central Office.
*
* .. Parameters ..
INTEGER IOFF
PARAMETER ( IOFF=32 )
* .. Intrinsic Functions ..
INTRINSIC ICHAR
* .. Executable Statements ..
*
* Test if the characters are equal
*
LSAME = CA .EQ. CB
*
* Now test for equivalence
*
IF ( .NOT.LSAME ) THEN
LSAME = ICHAR(CA) - IOFF .EQ. ICHAR(CB)
END IF
*
RETURN
*
* The following comments contain code for CDC systems using 6-12 bit
* representations.
*
* .. Parameters ..
* INTEGER ICIRFX
* PARAMETER ( ICIRFX=62 )
* .. Scalar Arguments ..
* CHARACTER*1 CB
* .. Array Arguments ..
* CHARACTER*1 CA(*)
* .. Local Scalars ..
* INTEGER IVAL
* .. Intrinsic Functions ..
* INTRINSIC ICHAR, CHAR
* .. Executable Statements ..
*
* See if the first character in string CA equals string CB.
*
* LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX)
*
* IF (LSAME) RETURN
*
* The characters are not identical. Now check them for equivalence.
* Look for the 'escape' character, circumflex, followed by the
* letter.
*
* IVAL = ICHAR(CA(2))
* IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN
* LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB
* END IF
*
* RETURN
*
* End of LSAME.
*
END
SUBROUTINE XERBLA ( SRNAME, INFO )
* .. Scalar Arguments ..
INTEGER INFO
CHARACTER*6 SRNAME
* ..
*
* Purpose
* =======
*
* XERBLA is an error handler for the Level 2 BLAS routines.
*
* It is called by the Level 2 BLAS routines if an input parameter is
* invalid.
*
* Installers should consider modifying the STOP statement in order to
* call system-specific exception-handling facilities.
*
* Parameters
* ==========
*
* SRNAME - CHARACTER*6.
* On entry, SRNAME specifies the name of the routine which
* called XERBLA.
*
* INFO - INTEGER.
* On entry, INFO specifies the position of the invalid
* parameter in the parameter-list of the calling routine.
*
*
* Auxiliary routine for Level 2 Blas.
*
* Written on 20-July-1986.
*
* .. Executable Statements ..
*
WRITE (*,99999) SRNAME, INFO
*
STOP
*
99999 FORMAT ( ' ** On entry to ', A6, ' parameter number ', I2,
$ ' had an illegal value' )
*
* End of XERBLA.
*
END