mirror of
https://gitlab.com/libeigen/eigen.git
synced 2026-04-10 11:34:33 +08:00
Pulled the latest changes from the trunk
This commit is contained in:
Benoit Steiner
@@ -14,23 +14,18 @@ endif()
|
||||
|
||||
add_custom_target(blas)
|
||||
|
||||
set(EigenBlas_SRCS single.cpp double.cpp complex_single.cpp complex_double.cpp xerbla.cpp)
|
||||
set(EigenBlas_SRCS single.cpp double.cpp complex_single.cpp complex_double.cpp xerbla.cpp
|
||||
f2c/srotm.c f2c/srotmg.c f2c/drotm.c f2c/drotmg.c
|
||||
f2c/lsame.c f2c/dspmv.c f2c/ssbmv.c f2c/chbmv.c
|
||||
f2c/sspmv.c f2c/zhbmv.c f2c/chpmv.c f2c/dsbmv.c
|
||||
f2c/zhpmv.c f2c/dtbmv.c f2c/stbmv.c f2c/ctbmv.c
|
||||
f2c/ztbmv.c f2c/d_cnjg.c f2c/r_cnjg.c
|
||||
)
|
||||
|
||||
if(EIGEN_Fortran_COMPILER_WORKS)
|
||||
|
||||
set(EigenBlas_SRCS ${EigenBlas_SRCS}
|
||||
complexdots.f
|
||||
srotm.f srotmg.f drotm.f drotmg.f
|
||||
lsame.f dspmv.f ssbmv.f
|
||||
chbmv.f sspmv.f
|
||||
zhbmv.f chpmv.f dsbmv.f
|
||||
zhpmv.f
|
||||
dtbmv.f stbmv.f ctbmv.f ztbmv.f
|
||||
)
|
||||
if (EIGEN_Fortran_COMPILER_WORKS)
|
||||
set(EigenBlas_SRCS ${EigenBlas_SRCS} fortran/complexdots.f)
|
||||
else()
|
||||
|
||||
message(WARNING " No fortran compiler has been detected, the blas build will be incomplete.")
|
||||
|
||||
set(EigenBlas_SRCS ${EigenBlas_SRCS} f2c/complexdots.c)
|
||||
endif()
|
||||
|
||||
add_library(eigen_blas_static ${EigenBlas_SRCS})
|
||||
|
||||
310
blas/chbmv.f
310
blas/chbmv.f
@@ -1,310 +0,0 @@
|
||||
SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,K,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* CHBMV performs the matrix-vector operation
|
||||
*
|
||||
* y := alpha*A*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are n element vectors and
|
||||
* A is an n by n hermitian band matrix, with k super-diagonals.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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 - COMPLEX .
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - COMPLEX 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 hermitian 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 hermitian 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 hermitian 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 hermitian 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 the imaginary parts of the diagonal elements need
|
||||
* not be set and are assumed to be zero.
|
||||
* 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 - COMPLEX 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 - COMPLEX .
|
||||
* On entry, BETA specifies the scalar beta.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - COMPLEX 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX 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 CONJG,MAX,MIN,REAL
|
||||
* ..
|
||||
*
|
||||
* 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('CHBMV ',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 + CONJG(A(L+I,J))*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*REAL(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 + CONJG(A(L+I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*REAL(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*REAL(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 + CONJG(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*REAL(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 + CONJG(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 CHBMV .
|
||||
*
|
||||
END
|
||||
272
blas/chpmv.f
272
blas/chpmv.f
@@ -1,272 +0,0 @@
|
||||
SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* CHPMV performs the matrix-vector operation
|
||||
*
|
||||
* y := alpha*A*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are n element vectors and
|
||||
* A is an n by n hermitian matrix, supplied in packed form.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the matrix A is supplied in the packed
|
||||
* array AP as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - COMPLEX .
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* AP - COMPLEX array of DIMENSION at least
|
||||
* ( ( n*( n + 1 ) )/2 ).
|
||||
* Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
* contain the upper triangular part of the hermitian matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
* and a( 2, 2 ) respectively, and so on.
|
||||
* Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
* contain the lower triangular part of the hermitian matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
* and a( 3, 1 ) respectively, and so on.
|
||||
* Note that the imaginary parts of the diagonal elements need
|
||||
* not be set and are assumed to be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - COMPLEX array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - COMPLEX .
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then Y need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - COMPLEX 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0E+0,0.0E+0))
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,REAL
|
||||
* ..
|
||||
*
|
||||
* 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('CHPMV ',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 + CONJG(AP(K))*X(I)
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*REAL(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 + CONJG(AP(K))*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*REAL(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*REAL(AP(KK))
|
||||
K = KK + 1
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + CONJG(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*REAL(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 + CONJG(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 CHPMV .
|
||||
*
|
||||
END
|
||||
366
blas/ctbmv.f
366
blas/ctbmv.f
@@ -1,366 +0,0 @@
|
||||
SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,K,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* CTBMV performs one of the matrix-vector operations
|
||||
*
|
||||
* x := A*x, or x := A'*x, or x := conjg( 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.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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 := conjg( 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 - COMPLEX 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 - COMPLEX 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0E+0,0.0E+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC CONJG,MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* 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('CTBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
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 or x := conjg( A' )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
L = KPLUS1 - J
|
||||
IF (NOCONJ) THEN
|
||||
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
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(KPLUS1,J))
|
||||
DO 100 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + CONJG(A(L+I,J))*X(I)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
KX = KX - INCX
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
|
||||
DO 120 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + A(L+I,J)*X(IX)
|
||||
IX = IX - INCX
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(KPLUS1,J))
|
||||
DO 130 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + CONJG(A(L+I,J))*X(IX)
|
||||
IX = IX - INCX
|
||||
130 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = 1,N
|
||||
TEMP = X(J)
|
||||
L = 1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(1,J)
|
||||
DO 150 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + A(L+I,J)*X(I)
|
||||
150 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(1,J))
|
||||
DO 160 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + CONJG(A(L+I,J))*X(I)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 200 J = 1,N
|
||||
TEMP = X(JX)
|
||||
KX = KX + INCX
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(1,J)
|
||||
DO 180 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + A(L+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*CONJG(A(1,J))
|
||||
DO 190 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + CONJG(A(L+I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
190 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of CTBMV .
|
||||
*
|
||||
END
|
||||
147
blas/drotm.f
147
blas/drotm.f
@@ -1,147 +0,0 @@
|
||||
SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DPARAM(5),DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
|
||||
*
|
||||
* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
|
||||
* (DY**T)
|
||||
*
|
||||
* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
|
||||
* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
|
||||
* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
*
|
||||
* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
|
||||
*
|
||||
* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
|
||||
* H=( ) ( ) ( ) ( )
|
||||
* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
|
||||
* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
|
||||
*
|
||||
* Arguments
|
||||
* =========
|
||||
*
|
||||
* N (input) INTEGER
|
||||
* number of elements in input vector(s)
|
||||
*
|
||||
* DX (input/output) DOUBLE PRECISION array, dimension N
|
||||
* double precision vector with N elements
|
||||
*
|
||||
* INCX (input) INTEGER
|
||||
* storage spacing between elements of DX
|
||||
*
|
||||
* DY (input/output) DOUBLE PRECISION array, dimension N
|
||||
* double precision vector with N elements
|
||||
*
|
||||
* INCY (input) INTEGER
|
||||
* storage spacing between elements of DY
|
||||
*
|
||||
* DPARAM (input/output) DOUBLE PRECISION array, dimension 5
|
||||
* DPARAM(1)=DFLAG
|
||||
* DPARAM(2)=DH11
|
||||
* DPARAM(3)=DH21
|
||||
* DPARAM(4)=DH12
|
||||
* DPARAM(5)=DH22
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,TWO,W,Z,ZERO
|
||||
INTEGER I,KX,KY,NSTEPS
|
||||
* ..
|
||||
* .. Data statements ..
|
||||
DATA ZERO,TWO/0.D0,2.D0/
|
||||
* ..
|
||||
*
|
||||
DFLAG = DPARAM(1)
|
||||
IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140
|
||||
IF (.NOT. (INCX.EQ.INCY.AND.INCX.GT.0)) GO TO 70
|
||||
*
|
||||
NSTEPS = N*INCX
|
||||
IF (DFLAG) 50,10,30
|
||||
10 CONTINUE
|
||||
DH12 = DPARAM(4)
|
||||
DH21 = DPARAM(3)
|
||||
DO 20 I = 1,NSTEPS,INCX
|
||||
W = DX(I)
|
||||
Z = DY(I)
|
||||
DX(I) = W + Z*DH12
|
||||
DY(I) = W*DH21 + Z
|
||||
20 CONTINUE
|
||||
GO TO 140
|
||||
30 CONTINUE
|
||||
DH11 = DPARAM(2)
|
||||
DH22 = DPARAM(5)
|
||||
DO 40 I = 1,NSTEPS,INCX
|
||||
W = DX(I)
|
||||
Z = DY(I)
|
||||
DX(I) = W*DH11 + Z
|
||||
DY(I) = -W + DH22*Z
|
||||
40 CONTINUE
|
||||
GO TO 140
|
||||
50 CONTINUE
|
||||
DH11 = DPARAM(2)
|
||||
DH12 = DPARAM(4)
|
||||
DH21 = DPARAM(3)
|
||||
DH22 = DPARAM(5)
|
||||
DO 60 I = 1,NSTEPS,INCX
|
||||
W = DX(I)
|
||||
Z = DY(I)
|
||||
DX(I) = W*DH11 + Z*DH12
|
||||
DY(I) = W*DH21 + Z*DH22
|
||||
60 CONTINUE
|
||||
GO TO 140
|
||||
70 CONTINUE
|
||||
KX = 1
|
||||
KY = 1
|
||||
IF (INCX.LT.0) KX = 1 + (1-N)*INCX
|
||||
IF (INCY.LT.0) KY = 1 + (1-N)*INCY
|
||||
*
|
||||
IF (DFLAG) 120,80,100
|
||||
80 CONTINUE
|
||||
DH12 = DPARAM(4)
|
||||
DH21 = DPARAM(3)
|
||||
DO 90 I = 1,N
|
||||
W = DX(KX)
|
||||
Z = DY(KY)
|
||||
DX(KX) = W + Z*DH12
|
||||
DY(KY) = W*DH21 + Z
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
90 CONTINUE
|
||||
GO TO 140
|
||||
100 CONTINUE
|
||||
DH11 = DPARAM(2)
|
||||
DH22 = DPARAM(5)
|
||||
DO 110 I = 1,N
|
||||
W = DX(KX)
|
||||
Z = DY(KY)
|
||||
DX(KX) = W*DH11 + Z
|
||||
DY(KY) = -W + DH22*Z
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
110 CONTINUE
|
||||
GO TO 140
|
||||
120 CONTINUE
|
||||
DH11 = DPARAM(2)
|
||||
DH12 = DPARAM(4)
|
||||
DH21 = DPARAM(3)
|
||||
DH22 = DPARAM(5)
|
||||
DO 130 I = 1,N
|
||||
W = DX(KX)
|
||||
Z = DY(KY)
|
||||
DX(KX) = W*DH11 + Z*DH12
|
||||
DY(KY) = W*DH21 + Z*DH22
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
206
blas/drotmg.f
206
blas/drotmg.f
@@ -1,206 +0,0 @@
|
||||
SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION DD1,DD2,DX1,DY1
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DPARAM(5)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
|
||||
* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*
|
||||
* DY2)**T.
|
||||
* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
*
|
||||
* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
|
||||
*
|
||||
* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
|
||||
* H=( ) ( ) ( ) ( )
|
||||
* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
|
||||
* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
|
||||
* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
|
||||
* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
|
||||
*
|
||||
* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
|
||||
* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
|
||||
* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
|
||||
*
|
||||
*
|
||||
* Arguments
|
||||
* =========
|
||||
*
|
||||
* DD1 (input/output) DOUBLE PRECISION
|
||||
*
|
||||
* DD2 (input/output) DOUBLE PRECISION
|
||||
*
|
||||
* DX1 (input/output) DOUBLE PRECISION
|
||||
*
|
||||
* DY1 (input) DOUBLE PRECISION
|
||||
*
|
||||
* DPARAM (input/output) DOUBLE PRECISION array, dimension 5
|
||||
* DPARAM(1)=DFLAG
|
||||
* DPARAM(2)=DH11
|
||||
* DPARAM(3)=DH21
|
||||
* DPARAM(4)=DH12
|
||||
* DPARAM(5)=DH22
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
|
||||
+ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
|
||||
INTEGER IGO
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DABS
|
||||
* ..
|
||||
* .. Data statements ..
|
||||
*
|
||||
DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
|
||||
DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
|
||||
* ..
|
||||
|
||||
IF (.NOT.DD1.LT.ZERO) GO TO 10
|
||||
* GO ZERO-H-D-AND-DX1..
|
||||
GO TO 60
|
||||
10 CONTINUE
|
||||
* CASE-DD1-NONNEGATIVE
|
||||
DP2 = DD2*DY1
|
||||
IF (.NOT.DP2.EQ.ZERO) GO TO 20
|
||||
DFLAG = -TWO
|
||||
GO TO 260
|
||||
* REGULAR-CASE..
|
||||
20 CONTINUE
|
||||
DP1 = DD1*DX1
|
||||
DQ2 = DP2*DY1
|
||||
DQ1 = DP1*DX1
|
||||
*
|
||||
IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40
|
||||
DH21 = -DY1/DX1
|
||||
DH12 = DP2/DP1
|
||||
*
|
||||
DU = ONE - DH12*DH21
|
||||
*
|
||||
IF (.NOT.DU.LE.ZERO) GO TO 30
|
||||
* GO ZERO-H-D-AND-DX1..
|
||||
GO TO 60
|
||||
30 CONTINUE
|
||||
DFLAG = ZERO
|
||||
DD1 = DD1/DU
|
||||
DD2 = DD2/DU
|
||||
DX1 = DX1*DU
|
||||
* GO SCALE-CHECK..
|
||||
GO TO 100
|
||||
40 CONTINUE
|
||||
IF (.NOT.DQ2.LT.ZERO) GO TO 50
|
||||
* GO ZERO-H-D-AND-DX1..
|
||||
GO TO 60
|
||||
50 CONTINUE
|
||||
DFLAG = ONE
|
||||
DH11 = DP1/DP2
|
||||
DH22 = DX1/DY1
|
||||
DU = ONE + DH11*DH22
|
||||
DTEMP = DD2/DU
|
||||
DD2 = DD1/DU
|
||||
DD1 = DTEMP
|
||||
DX1 = DY1*DU
|
||||
* GO SCALE-CHECK
|
||||
GO TO 100
|
||||
* PROCEDURE..ZERO-H-D-AND-DX1..
|
||||
60 CONTINUE
|
||||
DFLAG = -ONE
|
||||
DH11 = ZERO
|
||||
DH12 = ZERO
|
||||
DH21 = ZERO
|
||||
DH22 = ZERO
|
||||
*
|
||||
DD1 = ZERO
|
||||
DD2 = ZERO
|
||||
DX1 = ZERO
|
||||
* RETURN..
|
||||
GO TO 220
|
||||
* PROCEDURE..FIX-H..
|
||||
70 CONTINUE
|
||||
IF (.NOT.DFLAG.GE.ZERO) GO TO 90
|
||||
*
|
||||
IF (.NOT.DFLAG.EQ.ZERO) GO TO 80
|
||||
DH11 = ONE
|
||||
DH22 = ONE
|
||||
DFLAG = -ONE
|
||||
GO TO 90
|
||||
80 CONTINUE
|
||||
DH21 = -ONE
|
||||
DH12 = ONE
|
||||
DFLAG = -ONE
|
||||
90 CONTINUE
|
||||
GO TO IGO(120,150,180,210)
|
||||
* PROCEDURE..SCALE-CHECK
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
IF (.NOT.DD1.LE.RGAMSQ) GO TO 130
|
||||
IF (DD1.EQ.ZERO) GO TO 160
|
||||
ASSIGN 120 TO IGO
|
||||
* FIX-H..
|
||||
GO TO 70
|
||||
120 CONTINUE
|
||||
DD1 = DD1*GAM**2
|
||||
DX1 = DX1/GAM
|
||||
DH11 = DH11/GAM
|
||||
DH12 = DH12/GAM
|
||||
GO TO 110
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
IF (.NOT.DD1.GE.GAMSQ) GO TO 160
|
||||
ASSIGN 150 TO IGO
|
||||
* FIX-H..
|
||||
GO TO 70
|
||||
150 CONTINUE
|
||||
DD1 = DD1/GAM**2
|
||||
DX1 = DX1*GAM
|
||||
DH11 = DH11*GAM
|
||||
DH12 = DH12*GAM
|
||||
GO TO 140
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190
|
||||
IF (DD2.EQ.ZERO) GO TO 220
|
||||
ASSIGN 180 TO IGO
|
||||
* FIX-H..
|
||||
GO TO 70
|
||||
180 CONTINUE
|
||||
DD2 = DD2*GAM**2
|
||||
DH21 = DH21/GAM
|
||||
DH22 = DH22/GAM
|
||||
GO TO 170
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220
|
||||
ASSIGN 210 TO IGO
|
||||
* FIX-H..
|
||||
GO TO 70
|
||||
210 CONTINUE
|
||||
DD2 = DD2/GAM**2
|
||||
DH21 = DH21*GAM
|
||||
DH22 = DH22*GAM
|
||||
GO TO 200
|
||||
220 CONTINUE
|
||||
IF (DFLAG) 250,230,240
|
||||
230 CONTINUE
|
||||
DPARAM(3) = DH21
|
||||
DPARAM(4) = DH12
|
||||
GO TO 260
|
||||
240 CONTINUE
|
||||
DPARAM(2) = DH11
|
||||
DPARAM(5) = DH22
|
||||
GO TO 260
|
||||
250 CONTINUE
|
||||
DPARAM(2) = DH11
|
||||
DPARAM(3) = DH21
|
||||
DPARAM(4) = DH12
|
||||
DPARAM(5) = DH22
|
||||
260 CONTINUE
|
||||
DPARAM(1) = DFLAG
|
||||
RETURN
|
||||
END
|
||||
304
blas/dsbmv.f
304
blas/dsbmv.f
@@ -1,304 +0,0 @@
|
||||
SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,K,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSBMV 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.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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 - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION 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 - DOUBLE PRECISION 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 - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the
|
||||
* vector y. On exit, Y is overwritten by the updated vector y.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* 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('DSBMV ',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 DSBMV .
|
||||
*
|
||||
END
|
||||
265
blas/dspmv.f
265
blas/dspmv.f
@@ -1,265 +0,0 @@
|
||||
SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSPMV performs the matrix-vector operation
|
||||
*
|
||||
* y := alpha*A*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are n element vectors and
|
||||
* A is an n by n symmetric matrix, supplied in packed form.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the matrix A is supplied in the packed
|
||||
* array AP as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* AP - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( ( n*( n + 1 ) )/2 ).
|
||||
* Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
* contain the upper triangular part of the symmetric matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
* and a( 2, 2 ) respectively, and so on.
|
||||
* Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
* contain the lower triangular part of the symmetric matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
* and a( 3, 1 ) respectively, and so on.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then Y need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the n
|
||||
* element vector y. On exit, Y is overwritten by the updated
|
||||
* vector y.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSPMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when AP contains the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
K = KK
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(I)
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
|
||||
KK = KK + J
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 K = KK,KK + J - 2
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when AP contains the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*AP(KK)
|
||||
K = KK + 1
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(I)
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
KK = KK + (N-J+1)
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*AP(KK)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + AP(K)*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + (N-J+1)
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSPMV .
|
||||
*
|
||||
END
|
||||
335
blas/dtbmv.f
335
blas/dtbmv.f
@@ -1,335 +0,0 @@
|
||||
SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,K,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTBMV 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.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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 - DOUBLE PRECISION 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 - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x. 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* 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('DTBMV ',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 DTBMV .
|
||||
*
|
||||
END
|
||||
487
blas/f2c/chbmv.c
Normal file
487
blas/f2c/chbmv.c
Normal file
@@ -0,0 +1,487 @@
|
||||
/* chbmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex *
|
||||
alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
|
||||
beta, complex *y, integer *incy, ftnlen uplo_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
|
||||
real r__1;
|
||||
complex q__1, q__2, q__3, q__4;
|
||||
|
||||
/* Builtin functions */
|
||||
void r_cnjg(complex *, complex *);
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
|
||||
complex temp1, temp2;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
integer kplus1;
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* CHBMV performs the matrix-vector operation */
|
||||
|
||||
/* y := alpha*A*x + beta*y, */
|
||||
|
||||
/* where alpha and beta are scalars, x and y are n element vectors and */
|
||||
/* A is an n by n hermitian band matrix, with k super-diagonals. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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 - COMPLEX . */
|
||||
/* On entry, ALPHA specifies the scalar alpha. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* A - COMPLEX 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 hermitian 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 hermitian 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 hermitian 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 hermitian 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 the imaginary parts of the diagonal elements need */
|
||||
/* not be set and are assumed to be zero. */
|
||||
/* 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 - COMPLEX 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 - COMPLEX . */
|
||||
/* On entry, BETA specifies the scalar beta. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* Y - COMPLEX 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
--y;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*k < 0) {
|
||||
info = 3;
|
||||
} else if (*lda < *k + 1) {
|
||||
info = 6;
|
||||
} else if (*incx == 0) {
|
||||
info = 8;
|
||||
} else if (*incy == 0) {
|
||||
info = 11;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("CHBMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
|
||||
beta->i == 0.f))) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Set up the start points in X and Y. */
|
||||
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} else {
|
||||
ky = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
|
||||
/* 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->r != 1.f || beta->i != 0.f) {
|
||||
if (*incy == 1) {
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = i__;
|
||||
y[i__2].r = 0.f, y[i__2].i = 0.f;
|
||||
/* L10: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = i__;
|
||||
i__3 = i__;
|
||||
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
|
||||
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
|
||||
.r;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
/* L20: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iy = ky;
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = iy;
|
||||
y[i__2].r = 0.f, y[i__2].i = 0.f;
|
||||
iy += *incy;
|
||||
/* L30: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = iy;
|
||||
i__3 = iy;
|
||||
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
|
||||
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
|
||||
.r;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
iy += *incy;
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (alpha->r == 0.f && alpha->i == 0.f) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form y when upper triangle of A is stored. */
|
||||
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = j;
|
||||
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = q__1.r, temp1.i = q__1.i;
|
||||
temp2.r = 0.f, temp2.i = 0.f;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__2 = 1, i__3 = j - *k;
|
||||
i__4 = j - 1;
|
||||
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
|
||||
i__2 = i__;
|
||||
i__3 = i__;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
|
||||
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
|
||||
.r;
|
||||
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
|
||||
i__2 = i__;
|
||||
q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__2.i =
|
||||
q__3.r * x[i__2].i + q__3.i * x[i__2].r;
|
||||
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
|
||||
temp2.r = q__1.r, temp2.i = q__1.i;
|
||||
/* L50: */
|
||||
}
|
||||
i__4 = j;
|
||||
i__2 = j;
|
||||
i__3 = kplus1 + j * a_dim1;
|
||||
r__1 = a[i__3].r;
|
||||
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
|
||||
q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i;
|
||||
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
|
||||
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__4 = jx;
|
||||
q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i =
|
||||
alpha->r * x[i__4].i + alpha->i * x[i__4].r;
|
||||
temp1.r = q__1.r, temp1.i = q__1.i;
|
||||
temp2.r = 0.f, temp2.i = 0.f;
|
||||
ix = kx;
|
||||
iy = ky;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__2 = j - *k;
|
||||
i__3 = j - 1;
|
||||
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
|
||||
i__4 = iy;
|
||||
i__2 = iy;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
|
||||
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
|
||||
.r;
|
||||
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
|
||||
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
|
||||
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = ix;
|
||||
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
|
||||
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
|
||||
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
|
||||
temp2.r = q__1.r, temp2.i = q__1.i;
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
/* L70: */
|
||||
}
|
||||
i__3 = jy;
|
||||
i__4 = jy;
|
||||
i__2 = kplus1 + j * a_dim1;
|
||||
r__1 = a[i__2].r;
|
||||
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
|
||||
q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i;
|
||||
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
if (j > *k) {
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
}
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form y when lower triangle of A is stored. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__3 = j;
|
||||
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
|
||||
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
|
||||
temp1.r = q__1.r, temp1.i = q__1.i;
|
||||
temp2.r = 0.f, temp2.i = 0.f;
|
||||
i__3 = j;
|
||||
i__4 = j;
|
||||
i__2 = j * a_dim1 + 1;
|
||||
r__1 = a[i__2].r;
|
||||
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
|
||||
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__2 = j + *k;
|
||||
i__3 = min(i__4,i__2);
|
||||
for (i__ = j + 1; i__ <= i__3; ++i__) {
|
||||
i__4 = i__;
|
||||
i__2 = i__;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
|
||||
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
|
||||
.r;
|
||||
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
|
||||
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
|
||||
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = i__;
|
||||
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
|
||||
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
|
||||
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
|
||||
temp2.r = q__1.r, temp2.i = q__1.i;
|
||||
/* L90: */
|
||||
}
|
||||
i__3 = j;
|
||||
i__4 = j;
|
||||
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__3 = jx;
|
||||
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
|
||||
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
|
||||
temp1.r = q__1.r, temp1.i = q__1.i;
|
||||
temp2.r = 0.f, temp2.i = 0.f;
|
||||
i__3 = jy;
|
||||
i__4 = jy;
|
||||
i__2 = j * a_dim1 + 1;
|
||||
r__1 = a[i__2].r;
|
||||
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
|
||||
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
l = 1 - j;
|
||||
ix = jx;
|
||||
iy = jy;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__2 = j + *k;
|
||||
i__3 = min(i__4,i__2);
|
||||
for (i__ = j + 1; i__ <= i__3; ++i__) {
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
i__4 = iy;
|
||||
i__2 = iy;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
|
||||
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
|
||||
.r;
|
||||
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
|
||||
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
|
||||
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = ix;
|
||||
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
|
||||
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
|
||||
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
|
||||
temp2.r = q__1.r, temp2.i = q__1.i;
|
||||
/* L110: */
|
||||
}
|
||||
i__3 = jy;
|
||||
i__4 = jy;
|
||||
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of CHBMV . */
|
||||
|
||||
} /* chbmv_ */
|
||||
|
||||
438
blas/f2c/chpmv.c
Normal file
438
blas/f2c/chpmv.c
Normal file
@@ -0,0 +1,438 @@
|
||||
/* chpmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int chpmv_(char *uplo, integer *n, complex *alpha, complex *
|
||||
ap, complex *x, integer *incx, complex *beta, complex *y, integer *
|
||||
incy, ftnlen uplo_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer i__1, i__2, i__3, i__4, i__5;
|
||||
real r__1;
|
||||
complex q__1, q__2, q__3, q__4;
|
||||
|
||||
/* Builtin functions */
|
||||
void r_cnjg(complex *, complex *);
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
|
||||
complex temp1, temp2;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* CHPMV performs the matrix-vector operation */
|
||||
|
||||
/* y := alpha*A*x + beta*y, */
|
||||
|
||||
/* where alpha and beta are scalars, x and y are n element vectors and */
|
||||
/* A is an n by n hermitian matrix, supplied in packed form. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* UPLO - CHARACTER*1. */
|
||||
/* On entry, UPLO specifies whether the upper or lower */
|
||||
/* triangular part of the matrix A is supplied in the packed */
|
||||
/* array AP as follows: */
|
||||
|
||||
/* UPLO = 'U' or 'u' The upper triangular part of A is */
|
||||
/* supplied in AP. */
|
||||
|
||||
/* UPLO = 'L' or 'l' The lower triangular part of A is */
|
||||
/* supplied in AP. */
|
||||
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* N - INTEGER. */
|
||||
/* On entry, N specifies the order of the matrix A. */
|
||||
/* N must be at least zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* ALPHA - COMPLEX . */
|
||||
/* On entry, ALPHA specifies the scalar alpha. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* AP - COMPLEX array of DIMENSION at least */
|
||||
/* ( ( n*( n + 1 ) )/2 ). */
|
||||
/* Before entry with UPLO = 'U' or 'u', the array AP must */
|
||||
/* contain the upper triangular part of the hermitian matrix */
|
||||
/* packed sequentially, column by column, so that AP( 1 ) */
|
||||
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
|
||||
/* and a( 2, 2 ) respectively, and so on. */
|
||||
/* Before entry with UPLO = 'L' or 'l', the array AP must */
|
||||
/* contain the lower triangular part of the hermitian matrix */
|
||||
/* packed sequentially, column by column, so that AP( 1 ) */
|
||||
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
|
||||
/* and a( 3, 1 ) respectively, and so on. */
|
||||
/* Note that the imaginary parts of the diagonal elements need */
|
||||
/* not be set and are assumed to be zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* X - COMPLEX array of dimension at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
|
||||
/* Before entry, the incremented array X must contain the n */
|
||||
/* element vector x. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* INCX - INTEGER. */
|
||||
/* On entry, INCX specifies the increment for the elements of */
|
||||
/* X. INCX must not be zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* BETA - COMPLEX . */
|
||||
/* On entry, BETA specifies the scalar beta. When BETA is */
|
||||
/* supplied as zero then Y need not be set on input. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* Y - COMPLEX 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--y;
|
||||
--x;
|
||||
--ap;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*incx == 0) {
|
||||
info = 6;
|
||||
} else if (*incy == 0) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("CHPMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
|
||||
beta->i == 0.f))) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Set up the start points in X and Y. */
|
||||
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} else {
|
||||
ky = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
|
||||
/* 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->r != 1.f || beta->i != 0.f) {
|
||||
if (*incy == 1) {
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = i__;
|
||||
y[i__2].r = 0.f, y[i__2].i = 0.f;
|
||||
/* L10: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = i__;
|
||||
i__3 = i__;
|
||||
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
|
||||
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
|
||||
.r;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
/* L20: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iy = ky;
|
||||
if (beta->r == 0.f && beta->i == 0.f) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = iy;
|
||||
y[i__2].r = 0.f, y[i__2].i = 0.f;
|
||||
iy += *incy;
|
||||
/* L30: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = iy;
|
||||
i__3 = iy;
|
||||
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
|
||||
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
|
||||
.r;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
iy += *incy;
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (alpha->r == 0.f && alpha->i == 0.f) {
|
||||
return 0;
|
||||
}
|
||||
kk = 1;
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form y when AP contains the upper triangle. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = j;
|
||||
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = q__1.r, temp1.i = q__1.i;
|
||||
temp2.r = 0.f, temp2.i = 0.f;
|
||||
k = kk;
|
||||
i__2 = j - 1;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__;
|
||||
i__4 = i__;
|
||||
i__5 = k;
|
||||
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
|
||||
q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
|
||||
.r;
|
||||
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
r_cnjg(&q__3, &ap[k]);
|
||||
i__3 = i__;
|
||||
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
|
||||
q__3.r * x[i__3].i + q__3.i * x[i__3].r;
|
||||
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
|
||||
temp2.r = q__1.r, temp2.i = q__1.i;
|
||||
++k;
|
||||
/* L50: */
|
||||
}
|
||||
i__2 = j;
|
||||
i__3 = j;
|
||||
i__4 = kk + j - 1;
|
||||
r__1 = ap[i__4].r;
|
||||
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
|
||||
q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
|
||||
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
kk += j;
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = jx;
|
||||
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = q__1.r, temp1.i = q__1.i;
|
||||
temp2.r = 0.f, temp2.i = 0.f;
|
||||
ix = kx;
|
||||
iy = ky;
|
||||
i__2 = kk + j - 2;
|
||||
for (k = kk; k <= i__2; ++k) {
|
||||
i__3 = iy;
|
||||
i__4 = iy;
|
||||
i__5 = k;
|
||||
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
|
||||
q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
|
||||
.r;
|
||||
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
r_cnjg(&q__3, &ap[k]);
|
||||
i__3 = ix;
|
||||
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
|
||||
q__3.r * x[i__3].i + q__3.i * x[i__3].r;
|
||||
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
|
||||
temp2.r = q__1.r, temp2.i = q__1.i;
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
/* L70: */
|
||||
}
|
||||
i__2 = jy;
|
||||
i__3 = jy;
|
||||
i__4 = kk + j - 1;
|
||||
r__1 = ap[i__4].r;
|
||||
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
|
||||
q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
|
||||
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
kk += j;
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form y when AP contains the lower triangle. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = j;
|
||||
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = q__1.r, temp1.i = q__1.i;
|
||||
temp2.r = 0.f, temp2.i = 0.f;
|
||||
i__2 = j;
|
||||
i__3 = j;
|
||||
i__4 = kk;
|
||||
r__1 = ap[i__4].r;
|
||||
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
|
||||
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
k = kk + 1;
|
||||
i__2 = *n;
|
||||
for (i__ = j + 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__;
|
||||
i__4 = i__;
|
||||
i__5 = k;
|
||||
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
|
||||
q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
|
||||
.r;
|
||||
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
r_cnjg(&q__3, &ap[k]);
|
||||
i__3 = i__;
|
||||
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
|
||||
q__3.r * x[i__3].i + q__3.i * x[i__3].r;
|
||||
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
|
||||
temp2.r = q__1.r, temp2.i = q__1.i;
|
||||
++k;
|
||||
/* L90: */
|
||||
}
|
||||
i__2 = j;
|
||||
i__3 = j;
|
||||
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
kk += *n - j + 1;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = jx;
|
||||
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = q__1.r, temp1.i = q__1.i;
|
||||
temp2.r = 0.f, temp2.i = 0.f;
|
||||
i__2 = jy;
|
||||
i__3 = jy;
|
||||
i__4 = kk;
|
||||
r__1 = ap[i__4].r;
|
||||
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
|
||||
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
ix = jx;
|
||||
iy = jy;
|
||||
i__2 = kk + *n - j;
|
||||
for (k = kk + 1; k <= i__2; ++k) {
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
i__3 = iy;
|
||||
i__4 = iy;
|
||||
i__5 = k;
|
||||
q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
|
||||
q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
|
||||
.r;
|
||||
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
|
||||
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
|
||||
r_cnjg(&q__3, &ap[k]);
|
||||
i__3 = ix;
|
||||
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
|
||||
q__3.r * x[i__3].i + q__3.i * x[i__3].r;
|
||||
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
|
||||
temp2.r = q__1.r, temp2.i = q__1.i;
|
||||
/* L110: */
|
||||
}
|
||||
i__2 = jy;
|
||||
i__3 = jy;
|
||||
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
|
||||
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
kk += *n - j + 1;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of CHPMV . */
|
||||
|
||||
} /* chpmv_ */
|
||||
|
||||
84
blas/f2c/complexdots.c
Normal file
84
blas/f2c/complexdots.c
Normal file
@@ -0,0 +1,84 @@
|
||||
/* This file has been modified to use the standard gfortran calling
|
||||
convention, rather than the f2c calling convention.
|
||||
|
||||
It does not require -ff2c when compiled with gfortran.
|
||||
*/
|
||||
|
||||
/* complexdots.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
complex cdotc_(integer *n, complex *cx, integer
|
||||
*incx, complex *cy, integer *incy)
|
||||
{
|
||||
complex res;
|
||||
extern /* Subroutine */ int cdotcw_(integer *, complex *, integer *,
|
||||
complex *, integer *, complex *);
|
||||
|
||||
/* Parameter adjustments */
|
||||
--cy;
|
||||
--cx;
|
||||
|
||||
/* Function Body */
|
||||
cdotcw_(n, &cx[1], incx, &cy[1], incy, &res);
|
||||
return res;
|
||||
} /* cdotc_ */
|
||||
|
||||
complex cdotu_(integer *n, complex *cx, integer
|
||||
*incx, complex *cy, integer *incy)
|
||||
{
|
||||
complex res;
|
||||
extern /* Subroutine */ int cdotuw_(integer *, complex *, integer *,
|
||||
complex *, integer *, complex *);
|
||||
|
||||
/* Parameter adjustments */
|
||||
--cy;
|
||||
--cx;
|
||||
|
||||
/* Function Body */
|
||||
cdotuw_(n, &cx[1], incx, &cy[1], incy, &res);
|
||||
return res;
|
||||
} /* cdotu_ */
|
||||
|
||||
doublecomplex zdotc_(integer *n, doublecomplex *cx, integer *incx,
|
||||
doublecomplex *cy, integer *incy)
|
||||
{
|
||||
doublecomplex res;
|
||||
extern /* Subroutine */ int zdotcw_(integer *, doublecomplex *, integer *,
|
||||
doublecomplex *, integer *, doublecomplex *);
|
||||
|
||||
/* Parameter adjustments */
|
||||
--cy;
|
||||
--cx;
|
||||
|
||||
/* Function Body */
|
||||
zdotcw_(n, &cx[1], incx, &cy[1], incy, &res);
|
||||
return res;
|
||||
} /* zdotc_ */
|
||||
|
||||
doublecomplex zdotu_(integer *n, doublecomplex *cx, integer *incx,
|
||||
doublecomplex *cy, integer *incy)
|
||||
{
|
||||
doublecomplex res;
|
||||
extern /* Subroutine */ int zdotuw_(integer *, doublecomplex *, integer *,
|
||||
doublecomplex *, integer *, doublecomplex *);
|
||||
|
||||
/* Parameter adjustments */
|
||||
--cy;
|
||||
--cx;
|
||||
|
||||
/* Function Body */
|
||||
zdotuw_(n, &cx[1], incx, &cy[1], incy, &res);
|
||||
return res;
|
||||
} /* zdotu_ */
|
||||
|
||||
647
blas/f2c/ctbmv.c
Normal file
647
blas/f2c/ctbmv.c
Normal file
@@ -0,0 +1,647 @@
|
||||
/* ctbmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int ctbmv_(char *uplo, char *trans, char *diag, integer *n,
|
||||
integer *k, complex *a, integer *lda, complex *x, integer *incx,
|
||||
ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
|
||||
complex q__1, q__2, q__3;
|
||||
|
||||
/* Builtin functions */
|
||||
void r_cnjg(complex *, complex *);
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, l, ix, jx, kx, info;
|
||||
complex temp;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
integer kplus1;
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
logical noconj, nounit;
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* CTBMV performs one of the matrix-vector operations */
|
||||
|
||||
/* x := A*x, or x := A'*x, or x := conjg( 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. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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 := conjg( 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 - COMPLEX 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 - COMPLEX 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
|
||||
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
|
||||
ftnlen)1)) {
|
||||
info = 2;
|
||||
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
|
||||
"N", (ftnlen)1, (ftnlen)1)) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*k < 0) {
|
||||
info = 5;
|
||||
} else if (*lda < *k + 1) {
|
||||
info = 7;
|
||||
} else if (*incx == 0) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("CTBMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
|
||||
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
|
||||
|
||||
/* 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 <= 0) {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
} else if (*incx != 1) {
|
||||
kx = 1;
|
||||
}
|
||||
|
||||
/* Start the operations. In this version the elements of A are */
|
||||
/* accessed sequentially with one pass through A. */
|
||||
|
||||
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form x := A*x. */
|
||||
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = j;
|
||||
if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
|
||||
i__2 = j;
|
||||
temp.r = x[i__2].r, temp.i = x[i__2].i;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__2 = 1, i__3 = j - *k;
|
||||
i__4 = j - 1;
|
||||
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
|
||||
i__2 = i__;
|
||||
i__3 = i__;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
|
||||
q__2.i = temp.r * a[i__5].i + temp.i * a[
|
||||
i__5].r;
|
||||
q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
|
||||
q__2.i;
|
||||
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
|
||||
/* L10: */
|
||||
}
|
||||
if (nounit) {
|
||||
i__4 = j;
|
||||
i__2 = j;
|
||||
i__3 = kplus1 + j * a_dim1;
|
||||
q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
|
||||
i__3].i, q__1.i = x[i__2].r * a[i__3].i +
|
||||
x[i__2].i * a[i__3].r;
|
||||
x[i__4].r = q__1.r, x[i__4].i = q__1.i;
|
||||
}
|
||||
}
|
||||
/* L20: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__4 = jx;
|
||||
if (x[i__4].r != 0.f || x[i__4].i != 0.f) {
|
||||
i__4 = jx;
|
||||
temp.r = x[i__4].r, temp.i = x[i__4].i;
|
||||
ix = kx;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__2 = j - *k;
|
||||
i__3 = j - 1;
|
||||
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
|
||||
i__4 = ix;
|
||||
i__2 = ix;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
|
||||
q__2.i = temp.r * a[i__5].i + temp.i * a[
|
||||
i__5].r;
|
||||
q__1.r = x[i__2].r + q__2.r, q__1.i = x[i__2].i +
|
||||
q__2.i;
|
||||
x[i__4].r = q__1.r, x[i__4].i = q__1.i;
|
||||
ix += *incx;
|
||||
/* L30: */
|
||||
}
|
||||
if (nounit) {
|
||||
i__3 = jx;
|
||||
i__4 = jx;
|
||||
i__2 = kplus1 + j * a_dim1;
|
||||
q__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[
|
||||
i__2].i, q__1.i = x[i__4].r * a[i__2].i +
|
||||
x[i__4].i * a[i__2].r;
|
||||
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
|
||||
}
|
||||
}
|
||||
jx += *incx;
|
||||
if (j > *k) {
|
||||
kx += *incx;
|
||||
}
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
i__1 = j;
|
||||
if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
|
||||
i__1 = j;
|
||||
temp.r = x[i__1].r, temp.i = x[i__1].i;
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__3 = j + *k;
|
||||
i__4 = j + 1;
|
||||
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
|
||||
i__1 = i__;
|
||||
i__3 = i__;
|
||||
i__2 = l + i__ + j * a_dim1;
|
||||
q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
|
||||
q__2.i = temp.r * a[i__2].i + temp.i * a[
|
||||
i__2].r;
|
||||
q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
|
||||
q__2.i;
|
||||
x[i__1].r = q__1.r, x[i__1].i = q__1.i;
|
||||
/* L50: */
|
||||
}
|
||||
if (nounit) {
|
||||
i__4 = j;
|
||||
i__1 = j;
|
||||
i__3 = j * a_dim1 + 1;
|
||||
q__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[
|
||||
i__3].i, q__1.i = x[i__1].r * a[i__3].i +
|
||||
x[i__1].i * a[i__3].r;
|
||||
x[i__4].r = q__1.r, x[i__4].i = q__1.i;
|
||||
}
|
||||
}
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
i__4 = jx;
|
||||
if (x[i__4].r != 0.f || x[i__4].i != 0.f) {
|
||||
i__4 = jx;
|
||||
temp.r = x[i__4].r, temp.i = x[i__4].i;
|
||||
ix = kx;
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__1 = j + *k;
|
||||
i__3 = j + 1;
|
||||
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
|
||||
i__4 = ix;
|
||||
i__1 = ix;
|
||||
i__2 = l + i__ + j * a_dim1;
|
||||
q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
|
||||
q__2.i = temp.r * a[i__2].i + temp.i * a[
|
||||
i__2].r;
|
||||
q__1.r = x[i__1].r + q__2.r, q__1.i = x[i__1].i +
|
||||
q__2.i;
|
||||
x[i__4].r = q__1.r, x[i__4].i = q__1.i;
|
||||
ix -= *incx;
|
||||
/* L70: */
|
||||
}
|
||||
if (nounit) {
|
||||
i__3 = jx;
|
||||
i__4 = jx;
|
||||
i__1 = j * a_dim1 + 1;
|
||||
q__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[
|
||||
i__1].i, q__1.i = x[i__4].r * a[i__1].i +
|
||||
x[i__4].i * a[i__1].r;
|
||||
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
|
||||
}
|
||||
}
|
||||
jx -= *incx;
|
||||
if (*n - j >= *k) {
|
||||
kx -= *incx;
|
||||
}
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form x := A'*x or x := conjg( A' )*x. */
|
||||
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
i__3 = j;
|
||||
temp.r = x[i__3].r, temp.i = x[i__3].i;
|
||||
l = kplus1 - j;
|
||||
if (noconj) {
|
||||
if (nounit) {
|
||||
i__3 = kplus1 + j * a_dim1;
|
||||
q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
|
||||
q__1.i = temp.r * a[i__3].i + temp.i * a[
|
||||
i__3].r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
i__4 = l + i__ + j * a_dim1;
|
||||
i__1 = i__;
|
||||
q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
|
||||
i__1].i, q__2.i = a[i__4].r * x[i__1].i +
|
||||
a[i__4].i * x[i__1].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
|
||||
q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
/* L90: */
|
||||
}
|
||||
} else {
|
||||
if (nounit) {
|
||||
r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
|
||||
q__1.r = temp.r * q__2.r - temp.i * q__2.i,
|
||||
q__1.i = temp.r * q__2.i + temp.i *
|
||||
q__2.r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = i__;
|
||||
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
|
||||
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
|
||||
i__4].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
|
||||
q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
/* L100: */
|
||||
}
|
||||
}
|
||||
i__3 = j;
|
||||
x[i__3].r = temp.r, x[i__3].i = temp.i;
|
||||
/* L110: */
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
i__3 = jx;
|
||||
temp.r = x[i__3].r, temp.i = x[i__3].i;
|
||||
kx -= *incx;
|
||||
ix = kx;
|
||||
l = kplus1 - j;
|
||||
if (noconj) {
|
||||
if (nounit) {
|
||||
i__3 = kplus1 + j * a_dim1;
|
||||
q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
|
||||
q__1.i = temp.r * a[i__3].i + temp.i * a[
|
||||
i__3].r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
i__4 = l + i__ + j * a_dim1;
|
||||
i__1 = ix;
|
||||
q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
|
||||
i__1].i, q__2.i = a[i__4].r * x[i__1].i +
|
||||
a[i__4].i * x[i__1].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
|
||||
q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
ix -= *incx;
|
||||
/* L120: */
|
||||
}
|
||||
} else {
|
||||
if (nounit) {
|
||||
r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
|
||||
q__1.r = temp.r * q__2.r - temp.i * q__2.i,
|
||||
q__1.i = temp.r * q__2.i + temp.i *
|
||||
q__2.r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = ix;
|
||||
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
|
||||
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
|
||||
i__4].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
|
||||
q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
ix -= *incx;
|
||||
/* L130: */
|
||||
}
|
||||
}
|
||||
i__3 = jx;
|
||||
x[i__3].r = temp.r, x[i__3].i = temp.i;
|
||||
jx -= *incx;
|
||||
/* L140: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
i__3 = *n;
|
||||
for (j = 1; j <= i__3; ++j) {
|
||||
i__4 = j;
|
||||
temp.r = x[i__4].r, temp.i = x[i__4].i;
|
||||
l = 1 - j;
|
||||
if (noconj) {
|
||||
if (nounit) {
|
||||
i__4 = j * a_dim1 + 1;
|
||||
q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
|
||||
q__1.i = temp.r * a[i__4].i + temp.i * a[
|
||||
i__4].r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
i__1 = l + i__ + j * a_dim1;
|
||||
i__2 = i__;
|
||||
q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
|
||||
i__2].i, q__2.i = a[i__1].r * x[i__2].i +
|
||||
a[i__1].i * x[i__2].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
|
||||
q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
/* L150: */
|
||||
}
|
||||
} else {
|
||||
if (nounit) {
|
||||
r_cnjg(&q__2, &a[j * a_dim1 + 1]);
|
||||
q__1.r = temp.r * q__2.r - temp.i * q__2.i,
|
||||
q__1.i = temp.r * q__2.i + temp.i *
|
||||
q__2.r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
|
||||
i__1 = i__;
|
||||
q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
|
||||
q__2.i = q__3.r * x[i__1].i + q__3.i * x[
|
||||
i__1].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
|
||||
q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
/* L160: */
|
||||
}
|
||||
}
|
||||
i__4 = j;
|
||||
x[i__4].r = temp.r, x[i__4].i = temp.i;
|
||||
/* L170: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__3 = *n;
|
||||
for (j = 1; j <= i__3; ++j) {
|
||||
i__4 = jx;
|
||||
temp.r = x[i__4].r, temp.i = x[i__4].i;
|
||||
kx += *incx;
|
||||
ix = kx;
|
||||
l = 1 - j;
|
||||
if (noconj) {
|
||||
if (nounit) {
|
||||
i__4 = j * a_dim1 + 1;
|
||||
q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
|
||||
q__1.i = temp.r * a[i__4].i + temp.i * a[
|
||||
i__4].r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
i__1 = l + i__ + j * a_dim1;
|
||||
i__2 = ix;
|
||||
q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
|
||||
i__2].i, q__2.i = a[i__1].r * x[i__2].i +
|
||||
a[i__1].i * x[i__2].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
|
||||
q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
ix += *incx;
|
||||
/* L180: */
|
||||
}
|
||||
} else {
|
||||
if (nounit) {
|
||||
r_cnjg(&q__2, &a[j * a_dim1 + 1]);
|
||||
q__1.r = temp.r * q__2.r - temp.i * q__2.i,
|
||||
q__1.i = temp.r * q__2.i + temp.i *
|
||||
q__2.r;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
|
||||
i__1 = ix;
|
||||
q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
|
||||
q__2.i = q__3.r * x[i__1].i + q__3.i * x[
|
||||
i__1].r;
|
||||
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
|
||||
q__2.i;
|
||||
temp.r = q__1.r, temp.i = q__1.i;
|
||||
ix += *incx;
|
||||
/* L190: */
|
||||
}
|
||||
}
|
||||
i__4 = jx;
|
||||
x[i__4].r = temp.r, x[i__4].i = temp.i;
|
||||
jx += *incx;
|
||||
/* L200: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of CTBMV . */
|
||||
|
||||
} /* ctbmv_ */
|
||||
|
||||
6
blas/f2c/d_cnjg.c
Normal file
6
blas/f2c/d_cnjg.c
Normal file
@@ -0,0 +1,6 @@
|
||||
#include "datatypes.h"
|
||||
|
||||
void d_cnjg(doublecomplex *r, doublecomplex *z) {
|
||||
r->r = z->r;
|
||||
r->i = -(z->i);
|
||||
}
|
||||
24
blas/f2c/datatypes.h
Normal file
24
blas/f2c/datatypes.h
Normal file
@@ -0,0 +1,24 @@
|
||||
/* This contains a limited subset of the typedefs exposed by f2c
|
||||
for use by the Eigen BLAS C-only implementation.
|
||||
*/
|
||||
|
||||
#ifndef __EIGEN_DATATYPES_H__
|
||||
#define __EIGEN_DATATYPES_H__
|
||||
|
||||
typedef int integer;
|
||||
typedef unsigned int uinteger;
|
||||
typedef float real;
|
||||
typedef double doublereal;
|
||||
typedef struct { real r, i; } complex;
|
||||
typedef struct { doublereal r, i; } doublecomplex;
|
||||
typedef int ftnlen;
|
||||
typedef int logical;
|
||||
|
||||
#define abs(x) ((x) >= 0 ? (x) : -(x))
|
||||
#define dabs(x) (doublereal)abs(x)
|
||||
#define min(a,b) ((a) <= (b) ? (a) : (b))
|
||||
#define max(a,b) ((a) >= (b) ? (a) : (b))
|
||||
#define dmin(a,b) (doublereal)min(a,b)
|
||||
#define dmax(a,b) (doublereal)max(a,b)
|
||||
|
||||
#endif
|
||||
215
blas/f2c/drotm.c
Normal file
215
blas/f2c/drotm.c
Normal file
@@ -0,0 +1,215 @@
|
||||
/* drotm.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx,
|
||||
doublereal *dy, integer *incy, doublereal *dparam)
|
||||
{
|
||||
/* Initialized data */
|
||||
|
||||
static doublereal zero = 0.;
|
||||
static doublereal two = 2.;
|
||||
|
||||
/* System generated locals */
|
||||
integer i__1, i__2;
|
||||
|
||||
/* Local variables */
|
||||
integer i__;
|
||||
doublereal w, z__;
|
||||
integer kx, ky;
|
||||
doublereal dh11, dh12, dh21, dh22, dflag;
|
||||
integer nsteps;
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
|
||||
|
||||
/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */
|
||||
/* (DY**T) */
|
||||
|
||||
/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
|
||||
/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */
|
||||
/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
|
||||
|
||||
/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
|
||||
|
||||
/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
|
||||
/* H=( ) ( ) ( ) ( ) */
|
||||
/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
|
||||
/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========= */
|
||||
|
||||
/* N (input) INTEGER */
|
||||
/* number of elements in input vector(s) */
|
||||
|
||||
/* DX (input/output) DOUBLE PRECISION array, dimension N */
|
||||
/* double precision vector with N elements */
|
||||
|
||||
/* INCX (input) INTEGER */
|
||||
/* storage spacing between elements of DX */
|
||||
|
||||
/* DY (input/output) DOUBLE PRECISION array, dimension N */
|
||||
/* double precision vector with N elements */
|
||||
|
||||
/* INCY (input) INTEGER */
|
||||
/* storage spacing between elements of DY */
|
||||
|
||||
/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */
|
||||
/* DPARAM(1)=DFLAG */
|
||||
/* DPARAM(2)=DH11 */
|
||||
/* DPARAM(3)=DH21 */
|
||||
/* DPARAM(4)=DH12 */
|
||||
/* DPARAM(5)=DH22 */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. Data statements .. */
|
||||
/* Parameter adjustments */
|
||||
--dparam;
|
||||
--dy;
|
||||
--dx;
|
||||
|
||||
/* Function Body */
|
||||
/* .. */
|
||||
|
||||
dflag = dparam[1];
|
||||
if (*n <= 0 || dflag + two == zero) {
|
||||
goto L140;
|
||||
}
|
||||
if (! (*incx == *incy && *incx > 0)) {
|
||||
goto L70;
|
||||
}
|
||||
|
||||
nsteps = *n * *incx;
|
||||
if (dflag < 0.) {
|
||||
goto L50;
|
||||
} else if (dflag == 0) {
|
||||
goto L10;
|
||||
} else {
|
||||
goto L30;
|
||||
}
|
||||
L10:
|
||||
dh12 = dparam[4];
|
||||
dh21 = dparam[3];
|
||||
i__1 = nsteps;
|
||||
i__2 = *incx;
|
||||
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
|
||||
w = dx[i__];
|
||||
z__ = dy[i__];
|
||||
dx[i__] = w + z__ * dh12;
|
||||
dy[i__] = w * dh21 + z__;
|
||||
/* L20: */
|
||||
}
|
||||
goto L140;
|
||||
L30:
|
||||
dh11 = dparam[2];
|
||||
dh22 = dparam[5];
|
||||
i__2 = nsteps;
|
||||
i__1 = *incx;
|
||||
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
|
||||
w = dx[i__];
|
||||
z__ = dy[i__];
|
||||
dx[i__] = w * dh11 + z__;
|
||||
dy[i__] = -w + dh22 * z__;
|
||||
/* L40: */
|
||||
}
|
||||
goto L140;
|
||||
L50:
|
||||
dh11 = dparam[2];
|
||||
dh12 = dparam[4];
|
||||
dh21 = dparam[3];
|
||||
dh22 = dparam[5];
|
||||
i__1 = nsteps;
|
||||
i__2 = *incx;
|
||||
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
|
||||
w = dx[i__];
|
||||
z__ = dy[i__];
|
||||
dx[i__] = w * dh11 + z__ * dh12;
|
||||
dy[i__] = w * dh21 + z__ * dh22;
|
||||
/* L60: */
|
||||
}
|
||||
goto L140;
|
||||
L70:
|
||||
kx = 1;
|
||||
ky = 1;
|
||||
if (*incx < 0) {
|
||||
kx = (1 - *n) * *incx + 1;
|
||||
}
|
||||
if (*incy < 0) {
|
||||
ky = (1 - *n) * *incy + 1;
|
||||
}
|
||||
|
||||
if (dflag < 0.) {
|
||||
goto L120;
|
||||
} else if (dflag == 0) {
|
||||
goto L80;
|
||||
} else {
|
||||
goto L100;
|
||||
}
|
||||
L80:
|
||||
dh12 = dparam[4];
|
||||
dh21 = dparam[3];
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
w = dx[kx];
|
||||
z__ = dy[ky];
|
||||
dx[kx] = w + z__ * dh12;
|
||||
dy[ky] = w * dh21 + z__;
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
/* L90: */
|
||||
}
|
||||
goto L140;
|
||||
L100:
|
||||
dh11 = dparam[2];
|
||||
dh22 = dparam[5];
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
w = dx[kx];
|
||||
z__ = dy[ky];
|
||||
dx[kx] = w * dh11 + z__;
|
||||
dy[ky] = -w + dh22 * z__;
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
/* L110: */
|
||||
}
|
||||
goto L140;
|
||||
L120:
|
||||
dh11 = dparam[2];
|
||||
dh12 = dparam[4];
|
||||
dh21 = dparam[3];
|
||||
dh22 = dparam[5];
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
w = dx[kx];
|
||||
z__ = dy[ky];
|
||||
dx[kx] = w * dh11 + z__ * dh12;
|
||||
dy[ky] = w * dh21 + z__ * dh22;
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
/* L130: */
|
||||
}
|
||||
L140:
|
||||
return 0;
|
||||
} /* drotm_ */
|
||||
|
||||
293
blas/f2c/drotmg.c
Normal file
293
blas/f2c/drotmg.c
Normal file
@@ -0,0 +1,293 @@
|
||||
/* drotmg.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal *
|
||||
dx1, doublereal *dy1, doublereal *dparam)
|
||||
{
|
||||
/* Initialized data */
|
||||
|
||||
static doublereal zero = 0.;
|
||||
static doublereal one = 1.;
|
||||
static doublereal two = 2.;
|
||||
static doublereal gam = 4096.;
|
||||
static doublereal gamsq = 16777216.;
|
||||
static doublereal rgamsq = 5.9604645e-8;
|
||||
|
||||
/* Format strings */
|
||||
static char fmt_120[] = "";
|
||||
static char fmt_150[] = "";
|
||||
static char fmt_180[] = "";
|
||||
static char fmt_210[] = "";
|
||||
|
||||
/* System generated locals */
|
||||
doublereal d__1;
|
||||
|
||||
/* Local variables */
|
||||
doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22;
|
||||
integer igo;
|
||||
doublereal dflag, dtemp;
|
||||
|
||||
/* Assigned format variables */
|
||||
static char *igo_fmt;
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
|
||||
/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */
|
||||
/* DY2)**T. */
|
||||
/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
|
||||
|
||||
/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
|
||||
|
||||
/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
|
||||
/* H=( ) ( ) ( ) ( ) */
|
||||
/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
|
||||
/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */
|
||||
/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */
|
||||
/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */
|
||||
|
||||
/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
|
||||
/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
|
||||
/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
|
||||
|
||||
|
||||
/* Arguments */
|
||||
/* ========= */
|
||||
|
||||
/* DD1 (input/output) DOUBLE PRECISION */
|
||||
|
||||
/* DD2 (input/output) DOUBLE PRECISION */
|
||||
|
||||
/* DX1 (input/output) DOUBLE PRECISION */
|
||||
|
||||
/* DY1 (input) DOUBLE PRECISION */
|
||||
|
||||
/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */
|
||||
/* DPARAM(1)=DFLAG */
|
||||
/* DPARAM(2)=DH11 */
|
||||
/* DPARAM(3)=DH21 */
|
||||
/* DPARAM(4)=DH12 */
|
||||
/* DPARAM(5)=DH22 */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
/* .. Data statements .. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--dparam;
|
||||
|
||||
/* Function Body */
|
||||
/* .. */
|
||||
if (! (*dd1 < zero)) {
|
||||
goto L10;
|
||||
}
|
||||
/* GO ZERO-H-D-AND-DX1.. */
|
||||
goto L60;
|
||||
L10:
|
||||
/* CASE-DD1-NONNEGATIVE */
|
||||
dp2 = *dd2 * *dy1;
|
||||
if (! (dp2 == zero)) {
|
||||
goto L20;
|
||||
}
|
||||
dflag = -two;
|
||||
goto L260;
|
||||
/* REGULAR-CASE.. */
|
||||
L20:
|
||||
dp1 = *dd1 * *dx1;
|
||||
dq2 = dp2 * *dy1;
|
||||
dq1 = dp1 * *dx1;
|
||||
|
||||
if (! (abs(dq1) > abs(dq2))) {
|
||||
goto L40;
|
||||
}
|
||||
dh21 = -(*dy1) / *dx1;
|
||||
dh12 = dp2 / dp1;
|
||||
|
||||
du = one - dh12 * dh21;
|
||||
|
||||
if (! (du <= zero)) {
|
||||
goto L30;
|
||||
}
|
||||
/* GO ZERO-H-D-AND-DX1.. */
|
||||
goto L60;
|
||||
L30:
|
||||
dflag = zero;
|
||||
*dd1 /= du;
|
||||
*dd2 /= du;
|
||||
*dx1 *= du;
|
||||
/* GO SCALE-CHECK.. */
|
||||
goto L100;
|
||||
L40:
|
||||
if (! (dq2 < zero)) {
|
||||
goto L50;
|
||||
}
|
||||
/* GO ZERO-H-D-AND-DX1.. */
|
||||
goto L60;
|
||||
L50:
|
||||
dflag = one;
|
||||
dh11 = dp1 / dp2;
|
||||
dh22 = *dx1 / *dy1;
|
||||
du = one + dh11 * dh22;
|
||||
dtemp = *dd2 / du;
|
||||
*dd2 = *dd1 / du;
|
||||
*dd1 = dtemp;
|
||||
*dx1 = *dy1 * du;
|
||||
/* GO SCALE-CHECK */
|
||||
goto L100;
|
||||
/* PROCEDURE..ZERO-H-D-AND-DX1.. */
|
||||
L60:
|
||||
dflag = -one;
|
||||
dh11 = zero;
|
||||
dh12 = zero;
|
||||
dh21 = zero;
|
||||
dh22 = zero;
|
||||
|
||||
*dd1 = zero;
|
||||
*dd2 = zero;
|
||||
*dx1 = zero;
|
||||
/* RETURN.. */
|
||||
goto L220;
|
||||
/* PROCEDURE..FIX-H.. */
|
||||
L70:
|
||||
if (! (dflag >= zero)) {
|
||||
goto L90;
|
||||
}
|
||||
|
||||
if (! (dflag == zero)) {
|
||||
goto L80;
|
||||
}
|
||||
dh11 = one;
|
||||
dh22 = one;
|
||||
dflag = -one;
|
||||
goto L90;
|
||||
L80:
|
||||
dh21 = -one;
|
||||
dh12 = one;
|
||||
dflag = -one;
|
||||
L90:
|
||||
switch (igo) {
|
||||
case 0: goto L120;
|
||||
case 1: goto L150;
|
||||
case 2: goto L180;
|
||||
case 3: goto L210;
|
||||
}
|
||||
/* PROCEDURE..SCALE-CHECK */
|
||||
L100:
|
||||
L110:
|
||||
if (! (*dd1 <= rgamsq)) {
|
||||
goto L130;
|
||||
}
|
||||
if (*dd1 == zero) {
|
||||
goto L160;
|
||||
}
|
||||
igo = 0;
|
||||
igo_fmt = fmt_120;
|
||||
/* FIX-H.. */
|
||||
goto L70;
|
||||
L120:
|
||||
/* Computing 2nd power */
|
||||
d__1 = gam;
|
||||
*dd1 *= d__1 * d__1;
|
||||
*dx1 /= gam;
|
||||
dh11 /= gam;
|
||||
dh12 /= gam;
|
||||
goto L110;
|
||||
L130:
|
||||
L140:
|
||||
if (! (*dd1 >= gamsq)) {
|
||||
goto L160;
|
||||
}
|
||||
igo = 1;
|
||||
igo_fmt = fmt_150;
|
||||
/* FIX-H.. */
|
||||
goto L70;
|
||||
L150:
|
||||
/* Computing 2nd power */
|
||||
d__1 = gam;
|
||||
*dd1 /= d__1 * d__1;
|
||||
*dx1 *= gam;
|
||||
dh11 *= gam;
|
||||
dh12 *= gam;
|
||||
goto L140;
|
||||
L160:
|
||||
L170:
|
||||
if (! (abs(*dd2) <= rgamsq)) {
|
||||
goto L190;
|
||||
}
|
||||
if (*dd2 == zero) {
|
||||
goto L220;
|
||||
}
|
||||
igo = 2;
|
||||
igo_fmt = fmt_180;
|
||||
/* FIX-H.. */
|
||||
goto L70;
|
||||
L180:
|
||||
/* Computing 2nd power */
|
||||
d__1 = gam;
|
||||
*dd2 *= d__1 * d__1;
|
||||
dh21 /= gam;
|
||||
dh22 /= gam;
|
||||
goto L170;
|
||||
L190:
|
||||
L200:
|
||||
if (! (abs(*dd2) >= gamsq)) {
|
||||
goto L220;
|
||||
}
|
||||
igo = 3;
|
||||
igo_fmt = fmt_210;
|
||||
/* FIX-H.. */
|
||||
goto L70;
|
||||
L210:
|
||||
/* Computing 2nd power */
|
||||
d__1 = gam;
|
||||
*dd2 /= d__1 * d__1;
|
||||
dh21 *= gam;
|
||||
dh22 *= gam;
|
||||
goto L200;
|
||||
L220:
|
||||
if (dflag < 0.) {
|
||||
goto L250;
|
||||
} else if (dflag == 0) {
|
||||
goto L230;
|
||||
} else {
|
||||
goto L240;
|
||||
}
|
||||
L230:
|
||||
dparam[3] = dh21;
|
||||
dparam[4] = dh12;
|
||||
goto L260;
|
||||
L240:
|
||||
dparam[2] = dh11;
|
||||
dparam[5] = dh22;
|
||||
goto L260;
|
||||
L250:
|
||||
dparam[2] = dh11;
|
||||
dparam[3] = dh21;
|
||||
dparam[4] = dh12;
|
||||
dparam[5] = dh22;
|
||||
L260:
|
||||
dparam[1] = dflag;
|
||||
return 0;
|
||||
} /* drotmg_ */
|
||||
|
||||
366
blas/f2c/dsbmv.c
Normal file
366
blas/f2c/dsbmv.c
Normal file
@@ -0,0 +1,366 @@
|
||||
/* dsbmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal *
|
||||
alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
|
||||
doublereal *beta, doublereal *y, integer *incy, ftnlen uplo_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
|
||||
doublereal temp1, temp2;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
integer kplus1;
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* DSBMV 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. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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 - DOUBLE PRECISION. */
|
||||
/* On entry, ALPHA specifies the scalar alpha. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* A - DOUBLE PRECISION 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 - DOUBLE PRECISION 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 - DOUBLE PRECISION. */
|
||||
/* On entry, BETA specifies the scalar beta. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* Y - DOUBLE PRECISION array of DIMENSION at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCY ) ). */
|
||||
/* Before entry, the incremented array Y must contain the */
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
--y;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*k < 0) {
|
||||
info = 3;
|
||||
} else if (*lda < *k + 1) {
|
||||
info = 6;
|
||||
} else if (*incx == 0) {
|
||||
info = 8;
|
||||
} else if (*incy == 0) {
|
||||
info = 11;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("DSBMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Set up the start points in X and Y. */
|
||||
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} else {
|
||||
ky = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
|
||||
/* 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 != 1.) {
|
||||
if (*incy == 1) {
|
||||
if (*beta == 0.) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[i__] = 0.;
|
||||
/* L10: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[i__] = *beta * y[i__];
|
||||
/* L20: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iy = ky;
|
||||
if (*beta == 0.) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[iy] = 0.;
|
||||
iy += *incy;
|
||||
/* L30: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[iy] = *beta * y[iy];
|
||||
iy += *incy;
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (*alpha == 0.) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form y when upper triangle of A is stored. */
|
||||
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[j];
|
||||
temp2 = 0.;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__2 = 1, i__3 = j - *k;
|
||||
i__4 = j - 1;
|
||||
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
|
||||
y[i__] += temp1 * a[l + i__ + j * a_dim1];
|
||||
temp2 += a[l + i__ + j * a_dim1] * x[i__];
|
||||
/* L50: */
|
||||
}
|
||||
y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[jx];
|
||||
temp2 = 0.;
|
||||
ix = kx;
|
||||
iy = ky;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__2 = j - *k;
|
||||
i__3 = j - 1;
|
||||
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
|
||||
y[iy] += temp1 * a[l + i__ + j * a_dim1];
|
||||
temp2 += a[l + i__ + j * a_dim1] * x[ix];
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
/* L70: */
|
||||
}
|
||||
y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha *
|
||||
temp2;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
if (j > *k) {
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
}
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form y when lower triangle of A is stored. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[j];
|
||||
temp2 = 0.;
|
||||
y[j] += temp1 * a[j * a_dim1 + 1];
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__2 = j + *k;
|
||||
i__3 = min(i__4,i__2);
|
||||
for (i__ = j + 1; i__ <= i__3; ++i__) {
|
||||
y[i__] += temp1 * a[l + i__ + j * a_dim1];
|
||||
temp2 += a[l + i__ + j * a_dim1] * x[i__];
|
||||
/* L90: */
|
||||
}
|
||||
y[j] += *alpha * temp2;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[jx];
|
||||
temp2 = 0.;
|
||||
y[jy] += temp1 * a[j * a_dim1 + 1];
|
||||
l = 1 - j;
|
||||
ix = jx;
|
||||
iy = jy;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__2 = j + *k;
|
||||
i__3 = min(i__4,i__2);
|
||||
for (i__ = j + 1; i__ <= i__3; ++i__) {
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
y[iy] += temp1 * a[l + i__ + j * a_dim1];
|
||||
temp2 += a[l + i__ + j * a_dim1] * x[ix];
|
||||
/* L110: */
|
||||
}
|
||||
y[jy] += *alpha * temp2;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of DSBMV . */
|
||||
|
||||
} /* dsbmv_ */
|
||||
|
||||
316
blas/f2c/dspmv.c
Normal file
316
blas/f2c/dspmv.c
Normal file
@@ -0,0 +1,316 @@
|
||||
/* dspmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha,
|
||||
doublereal *ap, doublereal *x, integer *incx, doublereal *beta,
|
||||
doublereal *y, integer *incy, ftnlen uplo_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer i__1, i__2;
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
|
||||
doublereal temp1, temp2;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* DSPMV performs the matrix-vector operation */
|
||||
|
||||
/* y := alpha*A*x + beta*y, */
|
||||
|
||||
/* where alpha and beta are scalars, x and y are n element vectors and */
|
||||
/* A is an n by n symmetric matrix, supplied in packed form. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* UPLO - CHARACTER*1. */
|
||||
/* On entry, UPLO specifies whether the upper or lower */
|
||||
/* triangular part of the matrix A is supplied in the packed */
|
||||
/* array AP as follows: */
|
||||
|
||||
/* UPLO = 'U' or 'u' The upper triangular part of A is */
|
||||
/* supplied in AP. */
|
||||
|
||||
/* UPLO = 'L' or 'l' The lower triangular part of A is */
|
||||
/* supplied in AP. */
|
||||
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* N - INTEGER. */
|
||||
/* On entry, N specifies the order of the matrix A. */
|
||||
/* N must be at least zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* ALPHA - DOUBLE PRECISION. */
|
||||
/* On entry, ALPHA specifies the scalar alpha. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* AP - DOUBLE PRECISION array of DIMENSION at least */
|
||||
/* ( ( n*( n + 1 ) )/2 ). */
|
||||
/* Before entry with UPLO = 'U' or 'u', the array AP must */
|
||||
/* contain the upper triangular part of the symmetric matrix */
|
||||
/* packed sequentially, column by column, so that AP( 1 ) */
|
||||
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
|
||||
/* and a( 2, 2 ) respectively, and so on. */
|
||||
/* Before entry with UPLO = 'L' or 'l', the array AP must */
|
||||
/* contain the lower triangular part of the symmetric matrix */
|
||||
/* packed sequentially, column by column, so that AP( 1 ) */
|
||||
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
|
||||
/* and a( 3, 1 ) respectively, and so on. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* X - DOUBLE PRECISION array of dimension at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
|
||||
/* Before entry, the incremented array X must contain the n */
|
||||
/* element vector x. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* INCX - INTEGER. */
|
||||
/* On entry, INCX specifies the increment for the elements of */
|
||||
/* X. INCX must not be zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* BETA - DOUBLE PRECISION. */
|
||||
/* On entry, BETA specifies the scalar beta. When BETA is */
|
||||
/* supplied as zero then Y need not be set on input. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* Y - DOUBLE PRECISION array of dimension at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCY ) ). */
|
||||
/* Before entry, the incremented array Y must contain the n */
|
||||
/* element vector y. On exit, Y is overwritten by the updated */
|
||||
/* vector y. */
|
||||
|
||||
/* INCY - INTEGER. */
|
||||
/* On entry, INCY specifies the increment for the elements of */
|
||||
/* Y. INCY must not be zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--y;
|
||||
--x;
|
||||
--ap;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*incx == 0) {
|
||||
info = 6;
|
||||
} else if (*incy == 0) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("DSPMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Set up the start points in X and Y. */
|
||||
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} else {
|
||||
ky = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
|
||||
/* 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 != 1.) {
|
||||
if (*incy == 1) {
|
||||
if (*beta == 0.) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[i__] = 0.;
|
||||
/* L10: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[i__] = *beta * y[i__];
|
||||
/* L20: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iy = ky;
|
||||
if (*beta == 0.) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[iy] = 0.;
|
||||
iy += *incy;
|
||||
/* L30: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[iy] = *beta * y[iy];
|
||||
iy += *incy;
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (*alpha == 0.) {
|
||||
return 0;
|
||||
}
|
||||
kk = 1;
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form y when AP contains the upper triangle. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[j];
|
||||
temp2 = 0.;
|
||||
k = kk;
|
||||
i__2 = j - 1;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
y[i__] += temp1 * ap[k];
|
||||
temp2 += ap[k] * x[i__];
|
||||
++k;
|
||||
/* L50: */
|
||||
}
|
||||
y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
|
||||
kk += j;
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[jx];
|
||||
temp2 = 0.;
|
||||
ix = kx;
|
||||
iy = ky;
|
||||
i__2 = kk + j - 2;
|
||||
for (k = kk; k <= i__2; ++k) {
|
||||
y[iy] += temp1 * ap[k];
|
||||
temp2 += ap[k] * x[ix];
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
/* L70: */
|
||||
}
|
||||
y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
kk += j;
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form y when AP contains the lower triangle. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[j];
|
||||
temp2 = 0.;
|
||||
y[j] += temp1 * ap[kk];
|
||||
k = kk + 1;
|
||||
i__2 = *n;
|
||||
for (i__ = j + 1; i__ <= i__2; ++i__) {
|
||||
y[i__] += temp1 * ap[k];
|
||||
temp2 += ap[k] * x[i__];
|
||||
++k;
|
||||
/* L90: */
|
||||
}
|
||||
y[j] += *alpha * temp2;
|
||||
kk += *n - j + 1;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[jx];
|
||||
temp2 = 0.;
|
||||
y[jy] += temp1 * ap[kk];
|
||||
ix = jx;
|
||||
iy = jy;
|
||||
i__2 = kk + *n - j;
|
||||
for (k = kk + 1; k <= i__2; ++k) {
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
y[iy] += temp1 * ap[k];
|
||||
temp2 += ap[k] * x[ix];
|
||||
/* L110: */
|
||||
}
|
||||
y[jy] += *alpha * temp2;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
kk += *n - j + 1;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of DSPMV . */
|
||||
|
||||
} /* dspmv_ */
|
||||
|
||||
428
blas/f2c/dtbmv.c
Normal file
428
blas/f2c/dtbmv.c
Normal file
@@ -0,0 +1,428 @@
|
||||
/* dtbmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n,
|
||||
integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx,
|
||||
ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, l, ix, jx, kx, info;
|
||||
doublereal temp;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
integer kplus1;
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
logical nounit;
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* DTBMV 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. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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 - DOUBLE PRECISION 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 - DOUBLE PRECISION array of dimension at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
|
||||
/* Before entry, the incremented array X must contain the n */
|
||||
/* element vector x. 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
|
||||
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
|
||||
ftnlen)1)) {
|
||||
info = 2;
|
||||
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
|
||||
"N", (ftnlen)1, (ftnlen)1)) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*k < 0) {
|
||||
info = 5;
|
||||
} else if (*lda < *k + 1) {
|
||||
info = 7;
|
||||
} else if (*incx == 0) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("DTBMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
|
||||
|
||||
/* 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 <= 0) {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
} else if (*incx != 1) {
|
||||
kx = 1;
|
||||
}
|
||||
|
||||
/* Start the operations. In this version the elements of A are */
|
||||
/* accessed sequentially with one pass through A. */
|
||||
|
||||
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form x := A*x. */
|
||||
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (x[j] != 0.) {
|
||||
temp = x[j];
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__2 = 1, i__3 = j - *k;
|
||||
i__4 = j - 1;
|
||||
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
|
||||
x[i__] += temp * a[l + i__ + j * a_dim1];
|
||||
/* L10: */
|
||||
}
|
||||
if (nounit) {
|
||||
x[j] *= a[kplus1 + j * a_dim1];
|
||||
}
|
||||
}
|
||||
/* L20: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (x[jx] != 0.) {
|
||||
temp = x[jx];
|
||||
ix = kx;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__2 = j - *k;
|
||||
i__3 = j - 1;
|
||||
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
|
||||
x[ix] += temp * a[l + i__ + j * a_dim1];
|
||||
ix += *incx;
|
||||
/* L30: */
|
||||
}
|
||||
if (nounit) {
|
||||
x[jx] *= a[kplus1 + j * a_dim1];
|
||||
}
|
||||
}
|
||||
jx += *incx;
|
||||
if (j > *k) {
|
||||
kx += *incx;
|
||||
}
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
if (x[j] != 0.) {
|
||||
temp = x[j];
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__3 = j + *k;
|
||||
i__4 = j + 1;
|
||||
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
|
||||
x[i__] += temp * a[l + i__ + j * a_dim1];
|
||||
/* L50: */
|
||||
}
|
||||
if (nounit) {
|
||||
x[j] *= a[j * a_dim1 + 1];
|
||||
}
|
||||
}
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
if (x[jx] != 0.) {
|
||||
temp = x[jx];
|
||||
ix = kx;
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__1 = j + *k;
|
||||
i__3 = j + 1;
|
||||
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
|
||||
x[ix] += temp * a[l + i__ + j * a_dim1];
|
||||
ix -= *incx;
|
||||
/* L70: */
|
||||
}
|
||||
if (nounit) {
|
||||
x[jx] *= a[j * a_dim1 + 1];
|
||||
}
|
||||
}
|
||||
jx -= *incx;
|
||||
if (*n - j >= *k) {
|
||||
kx -= *incx;
|
||||
}
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form x := A'*x. */
|
||||
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
temp = x[j];
|
||||
l = kplus1 - j;
|
||||
if (nounit) {
|
||||
temp *= a[kplus1 + j * a_dim1];
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
temp += a[l + i__ + j * a_dim1] * x[i__];
|
||||
/* L90: */
|
||||
}
|
||||
x[j] = temp;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
temp = x[jx];
|
||||
kx -= *incx;
|
||||
ix = kx;
|
||||
l = kplus1 - j;
|
||||
if (nounit) {
|
||||
temp *= a[kplus1 + j * a_dim1];
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
temp += a[l + i__ + j * a_dim1] * x[ix];
|
||||
ix -= *incx;
|
||||
/* L110: */
|
||||
}
|
||||
x[jx] = temp;
|
||||
jx -= *incx;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
i__3 = *n;
|
||||
for (j = 1; j <= i__3; ++j) {
|
||||
temp = x[j];
|
||||
l = 1 - j;
|
||||
if (nounit) {
|
||||
temp *= a[j * a_dim1 + 1];
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
temp += a[l + i__ + j * a_dim1] * x[i__];
|
||||
/* L130: */
|
||||
}
|
||||
x[j] = temp;
|
||||
/* L140: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__3 = *n;
|
||||
for (j = 1; j <= i__3; ++j) {
|
||||
temp = x[jx];
|
||||
kx += *incx;
|
||||
ix = kx;
|
||||
l = 1 - j;
|
||||
if (nounit) {
|
||||
temp *= a[j * a_dim1 + 1];
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
temp += a[l + i__ + j * a_dim1] * x[ix];
|
||||
ix += *incx;
|
||||
/* L150: */
|
||||
}
|
||||
x[jx] = temp;
|
||||
jx += *incx;
|
||||
/* L160: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of DTBMV . */
|
||||
|
||||
} /* dtbmv_ */
|
||||
|
||||
117
blas/f2c/lsame.c
Normal file
117
blas/f2c/lsame.c
Normal file
@@ -0,0 +1,117 @@
|
||||
/* lsame.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
logical lsame_(char *ca, char *cb, ftnlen ca_len, ftnlen cb_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
logical ret_val;
|
||||
|
||||
/* Local variables */
|
||||
integer inta, intb, zcode;
|
||||
|
||||
|
||||
/* -- LAPACK auxiliary routine (version 3.1) -- */
|
||||
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
|
||||
/* November 2006 */
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* LSAME returns .TRUE. if CA is the same letter as CB regardless of */
|
||||
/* case. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========= */
|
||||
|
||||
/* CA (input) CHARACTER*1 */
|
||||
|
||||
/* CB (input) CHARACTER*1 */
|
||||
/* CA and CB specify the single characters to be compared. */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
|
||||
/* Test if the characters are equal */
|
||||
|
||||
ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
|
||||
if (ret_val) {
|
||||
return ret_val;
|
||||
}
|
||||
|
||||
/* Now test for equivalence if both characters are alphabetic. */
|
||||
|
||||
zcode = 'Z';
|
||||
|
||||
/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
|
||||
/* machines, on which ICHAR returns a value with bit 8 set. */
|
||||
/* ICHAR('A') on Prime machines returns 193 which is the same as */
|
||||
/* ICHAR('A') on an EBCDIC machine. */
|
||||
|
||||
inta = *(unsigned char *)ca;
|
||||
intb = *(unsigned char *)cb;
|
||||
|
||||
if (zcode == 90 || zcode == 122) {
|
||||
|
||||
/* ASCII is assumed - ZCODE is the ASCII code of either lower or */
|
||||
/* upper case 'Z'. */
|
||||
|
||||
if (inta >= 97 && inta <= 122) {
|
||||
inta += -32;
|
||||
}
|
||||
if (intb >= 97 && intb <= 122) {
|
||||
intb += -32;
|
||||
}
|
||||
|
||||
} else if (zcode == 233 || zcode == 169) {
|
||||
|
||||
/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
|
||||
/* upper case 'Z'. */
|
||||
|
||||
if ((inta >= 129 && inta <= 137) || (inta >= 145 && inta <= 153) ||
|
||||
(inta >= 162 && inta <= 169)) {
|
||||
inta += 64;
|
||||
}
|
||||
if ((intb >= 129 && intb <= 137) || (intb >= 145 && intb <= 153) ||
|
||||
(intb >= 162 && intb <= 169)) {
|
||||
intb += 64;
|
||||
}
|
||||
|
||||
} else if (zcode == 218 || zcode == 250) {
|
||||
|
||||
/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
|
||||
/* plus 128 of either lower or upper case 'Z'. */
|
||||
|
||||
if (inta >= 225 && inta <= 250) {
|
||||
inta += -32;
|
||||
}
|
||||
if (intb >= 225 && intb <= 250) {
|
||||
intb += -32;
|
||||
}
|
||||
}
|
||||
ret_val = inta == intb;
|
||||
|
||||
/* RETURN */
|
||||
|
||||
/* End of LSAME */
|
||||
|
||||
return ret_val;
|
||||
} /* lsame_ */
|
||||
|
||||
6
blas/f2c/r_cnjg.c
Normal file
6
blas/f2c/r_cnjg.c
Normal file
@@ -0,0 +1,6 @@
|
||||
#include "datatypes.h"
|
||||
|
||||
void r_cnjg(complex *r, complex *z) {
|
||||
r->r = z->r;
|
||||
r->i = -(z->i);
|
||||
}
|
||||
216
blas/f2c/srotm.c
Normal file
216
blas/f2c/srotm.c
Normal file
@@ -0,0 +1,216 @@
|
||||
/* srotm.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy,
|
||||
integer *incy, real *sparam)
|
||||
{
|
||||
/* Initialized data */
|
||||
|
||||
static real zero = 0.f;
|
||||
static real two = 2.f;
|
||||
|
||||
/* System generated locals */
|
||||
integer i__1, i__2;
|
||||
|
||||
/* Local variables */
|
||||
integer i__;
|
||||
real w, z__;
|
||||
integer kx, ky;
|
||||
real sh11, sh12, sh21, sh22, sflag;
|
||||
integer nsteps;
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
|
||||
|
||||
/* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */
|
||||
/* (DX**T) */
|
||||
|
||||
/* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
|
||||
/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */
|
||||
/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
|
||||
|
||||
/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
|
||||
|
||||
/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
|
||||
/* H=( ) ( ) ( ) ( ) */
|
||||
/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
|
||||
/* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */
|
||||
|
||||
|
||||
/* Arguments */
|
||||
/* ========= */
|
||||
|
||||
/* N (input) INTEGER */
|
||||
/* number of elements in input vector(s) */
|
||||
|
||||
/* SX (input/output) REAL array, dimension N */
|
||||
/* double precision vector with N elements */
|
||||
|
||||
/* INCX (input) INTEGER */
|
||||
/* storage spacing between elements of SX */
|
||||
|
||||
/* SY (input/output) REAL array, dimension N */
|
||||
/* double precision vector with N elements */
|
||||
|
||||
/* INCY (input) INTEGER */
|
||||
/* storage spacing between elements of SY */
|
||||
|
||||
/* SPARAM (input/output) REAL array, dimension 5 */
|
||||
/* SPARAM(1)=SFLAG */
|
||||
/* SPARAM(2)=SH11 */
|
||||
/* SPARAM(3)=SH21 */
|
||||
/* SPARAM(4)=SH12 */
|
||||
/* SPARAM(5)=SH22 */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. Data statements .. */
|
||||
/* Parameter adjustments */
|
||||
--sparam;
|
||||
--sy;
|
||||
--sx;
|
||||
|
||||
/* Function Body */
|
||||
/* .. */
|
||||
|
||||
sflag = sparam[1];
|
||||
if (*n <= 0 || sflag + two == zero) {
|
||||
goto L140;
|
||||
}
|
||||
if (! (*incx == *incy && *incx > 0)) {
|
||||
goto L70;
|
||||
}
|
||||
|
||||
nsteps = *n * *incx;
|
||||
if (sflag < 0.f) {
|
||||
goto L50;
|
||||
} else if (sflag == 0) {
|
||||
goto L10;
|
||||
} else {
|
||||
goto L30;
|
||||
}
|
||||
L10:
|
||||
sh12 = sparam[4];
|
||||
sh21 = sparam[3];
|
||||
i__1 = nsteps;
|
||||
i__2 = *incx;
|
||||
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
|
||||
w = sx[i__];
|
||||
z__ = sy[i__];
|
||||
sx[i__] = w + z__ * sh12;
|
||||
sy[i__] = w * sh21 + z__;
|
||||
/* L20: */
|
||||
}
|
||||
goto L140;
|
||||
L30:
|
||||
sh11 = sparam[2];
|
||||
sh22 = sparam[5];
|
||||
i__2 = nsteps;
|
||||
i__1 = *incx;
|
||||
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
|
||||
w = sx[i__];
|
||||
z__ = sy[i__];
|
||||
sx[i__] = w * sh11 + z__;
|
||||
sy[i__] = -w + sh22 * z__;
|
||||
/* L40: */
|
||||
}
|
||||
goto L140;
|
||||
L50:
|
||||
sh11 = sparam[2];
|
||||
sh12 = sparam[4];
|
||||
sh21 = sparam[3];
|
||||
sh22 = sparam[5];
|
||||
i__1 = nsteps;
|
||||
i__2 = *incx;
|
||||
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
|
||||
w = sx[i__];
|
||||
z__ = sy[i__];
|
||||
sx[i__] = w * sh11 + z__ * sh12;
|
||||
sy[i__] = w * sh21 + z__ * sh22;
|
||||
/* L60: */
|
||||
}
|
||||
goto L140;
|
||||
L70:
|
||||
kx = 1;
|
||||
ky = 1;
|
||||
if (*incx < 0) {
|
||||
kx = (1 - *n) * *incx + 1;
|
||||
}
|
||||
if (*incy < 0) {
|
||||
ky = (1 - *n) * *incy + 1;
|
||||
}
|
||||
|
||||
if (sflag < 0.f) {
|
||||
goto L120;
|
||||
} else if (sflag == 0) {
|
||||
goto L80;
|
||||
} else {
|
||||
goto L100;
|
||||
}
|
||||
L80:
|
||||
sh12 = sparam[4];
|
||||
sh21 = sparam[3];
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
w = sx[kx];
|
||||
z__ = sy[ky];
|
||||
sx[kx] = w + z__ * sh12;
|
||||
sy[ky] = w * sh21 + z__;
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
/* L90: */
|
||||
}
|
||||
goto L140;
|
||||
L100:
|
||||
sh11 = sparam[2];
|
||||
sh22 = sparam[5];
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
w = sx[kx];
|
||||
z__ = sy[ky];
|
||||
sx[kx] = w * sh11 + z__;
|
||||
sy[ky] = -w + sh22 * z__;
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
/* L110: */
|
||||
}
|
||||
goto L140;
|
||||
L120:
|
||||
sh11 = sparam[2];
|
||||
sh12 = sparam[4];
|
||||
sh21 = sparam[3];
|
||||
sh22 = sparam[5];
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
w = sx[kx];
|
||||
z__ = sy[ky];
|
||||
sx[kx] = w * sh11 + z__ * sh12;
|
||||
sy[ky] = w * sh21 + z__ * sh22;
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
/* L130: */
|
||||
}
|
||||
L140:
|
||||
return 0;
|
||||
} /* srotm_ */
|
||||
|
||||
295
blas/f2c/srotmg.c
Normal file
295
blas/f2c/srotmg.c
Normal file
@@ -0,0 +1,295 @@
|
||||
/* srotmg.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real
|
||||
*sparam)
|
||||
{
|
||||
/* Initialized data */
|
||||
|
||||
static real zero = 0.f;
|
||||
static real one = 1.f;
|
||||
static real two = 2.f;
|
||||
static real gam = 4096.f;
|
||||
static real gamsq = 16777200.f;
|
||||
static real rgamsq = 5.96046e-8f;
|
||||
|
||||
/* Format strings */
|
||||
static char fmt_120[] = "";
|
||||
static char fmt_150[] = "";
|
||||
static char fmt_180[] = "";
|
||||
static char fmt_210[] = "";
|
||||
|
||||
/* System generated locals */
|
||||
real r__1;
|
||||
|
||||
/* Local variables */
|
||||
real su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22;
|
||||
integer igo;
|
||||
real sflag, stemp;
|
||||
|
||||
/* Assigned format variables */
|
||||
static char *igo_fmt;
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
|
||||
/* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */
|
||||
/* SY2)**T. */
|
||||
/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
|
||||
|
||||
/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
|
||||
|
||||
/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
|
||||
/* H=( ) ( ) ( ) ( ) */
|
||||
/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
|
||||
/* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */
|
||||
/* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */
|
||||
/* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */
|
||||
|
||||
/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
|
||||
/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
|
||||
/* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
|
||||
|
||||
|
||||
/* Arguments */
|
||||
/* ========= */
|
||||
|
||||
|
||||
/* SD1 (input/output) REAL */
|
||||
|
||||
/* SD2 (input/output) REAL */
|
||||
|
||||
/* SX1 (input/output) REAL */
|
||||
|
||||
/* SY1 (input) REAL */
|
||||
|
||||
|
||||
/* SPARAM (input/output) REAL array, dimension 5 */
|
||||
/* SPARAM(1)=SFLAG */
|
||||
/* SPARAM(2)=SH11 */
|
||||
/* SPARAM(3)=SH21 */
|
||||
/* SPARAM(4)=SH12 */
|
||||
/* SPARAM(5)=SH22 */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
/* .. Data statements .. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--sparam;
|
||||
|
||||
/* Function Body */
|
||||
/* .. */
|
||||
if (! (*sd1 < zero)) {
|
||||
goto L10;
|
||||
}
|
||||
/* GO ZERO-H-D-AND-SX1.. */
|
||||
goto L60;
|
||||
L10:
|
||||
/* CASE-SD1-NONNEGATIVE */
|
||||
sp2 = *sd2 * *sy1;
|
||||
if (! (sp2 == zero)) {
|
||||
goto L20;
|
||||
}
|
||||
sflag = -two;
|
||||
goto L260;
|
||||
/* REGULAR-CASE.. */
|
||||
L20:
|
||||
sp1 = *sd1 * *sx1;
|
||||
sq2 = sp2 * *sy1;
|
||||
sq1 = sp1 * *sx1;
|
||||
|
||||
if (! (dabs(sq1) > dabs(sq2))) {
|
||||
goto L40;
|
||||
}
|
||||
sh21 = -(*sy1) / *sx1;
|
||||
sh12 = sp2 / sp1;
|
||||
|
||||
su = one - sh12 * sh21;
|
||||
|
||||
if (! (su <= zero)) {
|
||||
goto L30;
|
||||
}
|
||||
/* GO ZERO-H-D-AND-SX1.. */
|
||||
goto L60;
|
||||
L30:
|
||||
sflag = zero;
|
||||
*sd1 /= su;
|
||||
*sd2 /= su;
|
||||
*sx1 *= su;
|
||||
/* GO SCALE-CHECK.. */
|
||||
goto L100;
|
||||
L40:
|
||||
if (! (sq2 < zero)) {
|
||||
goto L50;
|
||||
}
|
||||
/* GO ZERO-H-D-AND-SX1.. */
|
||||
goto L60;
|
||||
L50:
|
||||
sflag = one;
|
||||
sh11 = sp1 / sp2;
|
||||
sh22 = *sx1 / *sy1;
|
||||
su = one + sh11 * sh22;
|
||||
stemp = *sd2 / su;
|
||||
*sd2 = *sd1 / su;
|
||||
*sd1 = stemp;
|
||||
*sx1 = *sy1 * su;
|
||||
/* GO SCALE-CHECK */
|
||||
goto L100;
|
||||
/* PROCEDURE..ZERO-H-D-AND-SX1.. */
|
||||
L60:
|
||||
sflag = -one;
|
||||
sh11 = zero;
|
||||
sh12 = zero;
|
||||
sh21 = zero;
|
||||
sh22 = zero;
|
||||
|
||||
*sd1 = zero;
|
||||
*sd2 = zero;
|
||||
*sx1 = zero;
|
||||
/* RETURN.. */
|
||||
goto L220;
|
||||
/* PROCEDURE..FIX-H.. */
|
||||
L70:
|
||||
if (! (sflag >= zero)) {
|
||||
goto L90;
|
||||
}
|
||||
|
||||
if (! (sflag == zero)) {
|
||||
goto L80;
|
||||
}
|
||||
sh11 = one;
|
||||
sh22 = one;
|
||||
sflag = -one;
|
||||
goto L90;
|
||||
L80:
|
||||
sh21 = -one;
|
||||
sh12 = one;
|
||||
sflag = -one;
|
||||
L90:
|
||||
switch (igo) {
|
||||
case 0: goto L120;
|
||||
case 1: goto L150;
|
||||
case 2: goto L180;
|
||||
case 3: goto L210;
|
||||
}
|
||||
/* PROCEDURE..SCALE-CHECK */
|
||||
L100:
|
||||
L110:
|
||||
if (! (*sd1 <= rgamsq)) {
|
||||
goto L130;
|
||||
}
|
||||
if (*sd1 == zero) {
|
||||
goto L160;
|
||||
}
|
||||
igo = 0;
|
||||
igo_fmt = fmt_120;
|
||||
/* FIX-H.. */
|
||||
goto L70;
|
||||
L120:
|
||||
/* Computing 2nd power */
|
||||
r__1 = gam;
|
||||
*sd1 *= r__1 * r__1;
|
||||
*sx1 /= gam;
|
||||
sh11 /= gam;
|
||||
sh12 /= gam;
|
||||
goto L110;
|
||||
L130:
|
||||
L140:
|
||||
if (! (*sd1 >= gamsq)) {
|
||||
goto L160;
|
||||
}
|
||||
igo = 1;
|
||||
igo_fmt = fmt_150;
|
||||
/* FIX-H.. */
|
||||
goto L70;
|
||||
L150:
|
||||
/* Computing 2nd power */
|
||||
r__1 = gam;
|
||||
*sd1 /= r__1 * r__1;
|
||||
*sx1 *= gam;
|
||||
sh11 *= gam;
|
||||
sh12 *= gam;
|
||||
goto L140;
|
||||
L160:
|
||||
L170:
|
||||
if (! (dabs(*sd2) <= rgamsq)) {
|
||||
goto L190;
|
||||
}
|
||||
if (*sd2 == zero) {
|
||||
goto L220;
|
||||
}
|
||||
igo = 2;
|
||||
igo_fmt = fmt_180;
|
||||
/* FIX-H.. */
|
||||
goto L70;
|
||||
L180:
|
||||
/* Computing 2nd power */
|
||||
r__1 = gam;
|
||||
*sd2 *= r__1 * r__1;
|
||||
sh21 /= gam;
|
||||
sh22 /= gam;
|
||||
goto L170;
|
||||
L190:
|
||||
L200:
|
||||
if (! (dabs(*sd2) >= gamsq)) {
|
||||
goto L220;
|
||||
}
|
||||
igo = 3;
|
||||
igo_fmt = fmt_210;
|
||||
/* FIX-H.. */
|
||||
goto L70;
|
||||
L210:
|
||||
/* Computing 2nd power */
|
||||
r__1 = gam;
|
||||
*sd2 /= r__1 * r__1;
|
||||
sh21 *= gam;
|
||||
sh22 *= gam;
|
||||
goto L200;
|
||||
L220:
|
||||
if (sflag < 0.f) {
|
||||
goto L250;
|
||||
} else if (sflag == 0) {
|
||||
goto L230;
|
||||
} else {
|
||||
goto L240;
|
||||
}
|
||||
L230:
|
||||
sparam[3] = sh21;
|
||||
sparam[4] = sh12;
|
||||
goto L260;
|
||||
L240:
|
||||
sparam[2] = sh11;
|
||||
sparam[5] = sh22;
|
||||
goto L260;
|
||||
L250:
|
||||
sparam[2] = sh11;
|
||||
sparam[3] = sh21;
|
||||
sparam[4] = sh12;
|
||||
sparam[5] = sh22;
|
||||
L260:
|
||||
sparam[1] = sflag;
|
||||
return 0;
|
||||
} /* srotmg_ */
|
||||
|
||||
368
blas/f2c/ssbmv.c
Normal file
368
blas/f2c/ssbmv.c
Normal file
@@ -0,0 +1,368 @@
|
||||
/* ssbmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha,
|
||||
real *a, integer *lda, real *x, integer *incx, real *beta, real *y,
|
||||
integer *incy, ftnlen uplo_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
|
||||
real temp1, temp2;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
integer kplus1;
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* 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. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
--y;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*k < 0) {
|
||||
info = 3;
|
||||
} else if (*lda < *k + 1) {
|
||||
info = 6;
|
||||
} else if (*incx == 0) {
|
||||
info = 8;
|
||||
} else if (*incy == 0) {
|
||||
info = 11;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("SSBMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Set up the start points in X and Y. */
|
||||
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} else {
|
||||
ky = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
|
||||
/* 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 != 1.f) {
|
||||
if (*incy == 1) {
|
||||
if (*beta == 0.f) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[i__] = 0.f;
|
||||
/* L10: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[i__] = *beta * y[i__];
|
||||
/* L20: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iy = ky;
|
||||
if (*beta == 0.f) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[iy] = 0.f;
|
||||
iy += *incy;
|
||||
/* L30: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[iy] = *beta * y[iy];
|
||||
iy += *incy;
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (*alpha == 0.f) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form y when upper triangle of A is stored. */
|
||||
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[j];
|
||||
temp2 = 0.f;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__2 = 1, i__3 = j - *k;
|
||||
i__4 = j - 1;
|
||||
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
|
||||
y[i__] += temp1 * a[l + i__ + j * a_dim1];
|
||||
temp2 += a[l + i__ + j * a_dim1] * x[i__];
|
||||
/* L50: */
|
||||
}
|
||||
y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[jx];
|
||||
temp2 = 0.f;
|
||||
ix = kx;
|
||||
iy = ky;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__2 = j - *k;
|
||||
i__3 = j - 1;
|
||||
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
|
||||
y[iy] += temp1 * a[l + i__ + j * a_dim1];
|
||||
temp2 += a[l + i__ + j * a_dim1] * x[ix];
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
/* L70: */
|
||||
}
|
||||
y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha *
|
||||
temp2;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
if (j > *k) {
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
}
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form y when lower triangle of A is stored. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[j];
|
||||
temp2 = 0.f;
|
||||
y[j] += temp1 * a[j * a_dim1 + 1];
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__2 = j + *k;
|
||||
i__3 = min(i__4,i__2);
|
||||
for (i__ = j + 1; i__ <= i__3; ++i__) {
|
||||
y[i__] += temp1 * a[l + i__ + j * a_dim1];
|
||||
temp2 += a[l + i__ + j * a_dim1] * x[i__];
|
||||
/* L90: */
|
||||
}
|
||||
y[j] += *alpha * temp2;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[jx];
|
||||
temp2 = 0.f;
|
||||
y[jy] += temp1 * a[j * a_dim1 + 1];
|
||||
l = 1 - j;
|
||||
ix = jx;
|
||||
iy = jy;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__2 = j + *k;
|
||||
i__3 = min(i__4,i__2);
|
||||
for (i__ = j + 1; i__ <= i__3; ++i__) {
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
y[iy] += temp1 * a[l + i__ + j * a_dim1];
|
||||
temp2 += a[l + i__ + j * a_dim1] * x[ix];
|
||||
/* L110: */
|
||||
}
|
||||
y[jy] += *alpha * temp2;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of SSBMV . */
|
||||
|
||||
} /* ssbmv_ */
|
||||
|
||||
316
blas/f2c/sspmv.c
Normal file
316
blas/f2c/sspmv.c
Normal file
@@ -0,0 +1,316 @@
|
||||
/* sspmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap,
|
||||
real *x, integer *incx, real *beta, real *y, integer *incy, ftnlen
|
||||
uplo_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer i__1, i__2;
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
|
||||
real temp1, temp2;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* 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. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--y;
|
||||
--x;
|
||||
--ap;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*incx == 0) {
|
||||
info = 6;
|
||||
} else if (*incy == 0) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("SSPMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Set up the start points in X and Y. */
|
||||
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} else {
|
||||
ky = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
|
||||
/* 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 != 1.f) {
|
||||
if (*incy == 1) {
|
||||
if (*beta == 0.f) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[i__] = 0.f;
|
||||
/* L10: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[i__] = *beta * y[i__];
|
||||
/* L20: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iy = ky;
|
||||
if (*beta == 0.f) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[iy] = 0.f;
|
||||
iy += *incy;
|
||||
/* L30: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
y[iy] = *beta * y[iy];
|
||||
iy += *incy;
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (*alpha == 0.f) {
|
||||
return 0;
|
||||
}
|
||||
kk = 1;
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form y when AP contains the upper triangle. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[j];
|
||||
temp2 = 0.f;
|
||||
k = kk;
|
||||
i__2 = j - 1;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
y[i__] += temp1 * ap[k];
|
||||
temp2 += ap[k] * x[i__];
|
||||
++k;
|
||||
/* L50: */
|
||||
}
|
||||
y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
|
||||
kk += j;
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[jx];
|
||||
temp2 = 0.f;
|
||||
ix = kx;
|
||||
iy = ky;
|
||||
i__2 = kk + j - 2;
|
||||
for (k = kk; k <= i__2; ++k) {
|
||||
y[iy] += temp1 * ap[k];
|
||||
temp2 += ap[k] * x[ix];
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
/* L70: */
|
||||
}
|
||||
y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
kk += j;
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form y when AP contains the lower triangle. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[j];
|
||||
temp2 = 0.f;
|
||||
y[j] += temp1 * ap[kk];
|
||||
k = kk + 1;
|
||||
i__2 = *n;
|
||||
for (i__ = j + 1; i__ <= i__2; ++i__) {
|
||||
y[i__] += temp1 * ap[k];
|
||||
temp2 += ap[k] * x[i__];
|
||||
++k;
|
||||
/* L90: */
|
||||
}
|
||||
y[j] += *alpha * temp2;
|
||||
kk += *n - j + 1;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
temp1 = *alpha * x[jx];
|
||||
temp2 = 0.f;
|
||||
y[jy] += temp1 * ap[kk];
|
||||
ix = jx;
|
||||
iy = jy;
|
||||
i__2 = kk + *n - j;
|
||||
for (k = kk + 1; k <= i__2; ++k) {
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
y[iy] += temp1 * ap[k];
|
||||
temp2 += ap[k] * x[ix];
|
||||
/* L110: */
|
||||
}
|
||||
y[jy] += *alpha * temp2;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
kk += *n - j + 1;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of SSPMV . */
|
||||
|
||||
} /* sspmv_ */
|
||||
|
||||
428
blas/f2c/stbmv.c
Normal file
428
blas/f2c/stbmv.c
Normal file
@@ -0,0 +1,428 @@
|
||||
/* stbmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n,
|
||||
integer *k, real *a, integer *lda, real *x, integer *incx, ftnlen
|
||||
uplo_len, ftnlen trans_len, ftnlen diag_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, l, ix, jx, kx, info;
|
||||
real temp;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
integer kplus1;
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
logical nounit;
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* 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. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
|
||||
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
|
||||
ftnlen)1)) {
|
||||
info = 2;
|
||||
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
|
||||
"N", (ftnlen)1, (ftnlen)1)) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*k < 0) {
|
||||
info = 5;
|
||||
} else if (*lda < *k + 1) {
|
||||
info = 7;
|
||||
} else if (*incx == 0) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("STBMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
|
||||
|
||||
/* 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 <= 0) {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
} else if (*incx != 1) {
|
||||
kx = 1;
|
||||
}
|
||||
|
||||
/* Start the operations. In this version the elements of A are */
|
||||
/* accessed sequentially with one pass through A. */
|
||||
|
||||
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form x := A*x. */
|
||||
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (x[j] != 0.f) {
|
||||
temp = x[j];
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__2 = 1, i__3 = j - *k;
|
||||
i__4 = j - 1;
|
||||
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
|
||||
x[i__] += temp * a[l + i__ + j * a_dim1];
|
||||
/* L10: */
|
||||
}
|
||||
if (nounit) {
|
||||
x[j] *= a[kplus1 + j * a_dim1];
|
||||
}
|
||||
}
|
||||
/* L20: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
if (x[jx] != 0.f) {
|
||||
temp = x[jx];
|
||||
ix = kx;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__2 = j - *k;
|
||||
i__3 = j - 1;
|
||||
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
|
||||
x[ix] += temp * a[l + i__ + j * a_dim1];
|
||||
ix += *incx;
|
||||
/* L30: */
|
||||
}
|
||||
if (nounit) {
|
||||
x[jx] *= a[kplus1 + j * a_dim1];
|
||||
}
|
||||
}
|
||||
jx += *incx;
|
||||
if (j > *k) {
|
||||
kx += *incx;
|
||||
}
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
if (x[j] != 0.f) {
|
||||
temp = x[j];
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__3 = j + *k;
|
||||
i__4 = j + 1;
|
||||
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
|
||||
x[i__] += temp * a[l + i__ + j * a_dim1];
|
||||
/* L50: */
|
||||
}
|
||||
if (nounit) {
|
||||
x[j] *= a[j * a_dim1 + 1];
|
||||
}
|
||||
}
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
if (x[jx] != 0.f) {
|
||||
temp = x[jx];
|
||||
ix = kx;
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__1 = j + *k;
|
||||
i__3 = j + 1;
|
||||
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
|
||||
x[ix] += temp * a[l + i__ + j * a_dim1];
|
||||
ix -= *incx;
|
||||
/* L70: */
|
||||
}
|
||||
if (nounit) {
|
||||
x[jx] *= a[j * a_dim1 + 1];
|
||||
}
|
||||
}
|
||||
jx -= *incx;
|
||||
if (*n - j >= *k) {
|
||||
kx -= *incx;
|
||||
}
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form x := A'*x. */
|
||||
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
temp = x[j];
|
||||
l = kplus1 - j;
|
||||
if (nounit) {
|
||||
temp *= a[kplus1 + j * a_dim1];
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
temp += a[l + i__ + j * a_dim1] * x[i__];
|
||||
/* L90: */
|
||||
}
|
||||
x[j] = temp;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
temp = x[jx];
|
||||
kx -= *incx;
|
||||
ix = kx;
|
||||
l = kplus1 - j;
|
||||
if (nounit) {
|
||||
temp *= a[kplus1 + j * a_dim1];
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
temp += a[l + i__ + j * a_dim1] * x[ix];
|
||||
ix -= *incx;
|
||||
/* L110: */
|
||||
}
|
||||
x[jx] = temp;
|
||||
jx -= *incx;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
i__3 = *n;
|
||||
for (j = 1; j <= i__3; ++j) {
|
||||
temp = x[j];
|
||||
l = 1 - j;
|
||||
if (nounit) {
|
||||
temp *= a[j * a_dim1 + 1];
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
temp += a[l + i__ + j * a_dim1] * x[i__];
|
||||
/* L130: */
|
||||
}
|
||||
x[j] = temp;
|
||||
/* L140: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__3 = *n;
|
||||
for (j = 1; j <= i__3; ++j) {
|
||||
temp = x[jx];
|
||||
kx += *incx;
|
||||
ix = kx;
|
||||
l = 1 - j;
|
||||
if (nounit) {
|
||||
temp *= a[j * a_dim1 + 1];
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
temp += a[l + i__ + j * a_dim1] * x[ix];
|
||||
ix += *incx;
|
||||
/* L150: */
|
||||
}
|
||||
x[jx] = temp;
|
||||
jx += *incx;
|
||||
/* L160: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of STBMV . */
|
||||
|
||||
} /* stbmv_ */
|
||||
|
||||
488
blas/f2c/zhbmv.c
Normal file
488
blas/f2c/zhbmv.c
Normal file
@@ -0,0 +1,488 @@
|
||||
/* zhbmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int zhbmv_(char *uplo, integer *n, integer *k, doublecomplex
|
||||
*alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer *
|
||||
incx, doublecomplex *beta, doublecomplex *y, integer *incy, ftnlen
|
||||
uplo_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
|
||||
doublereal d__1;
|
||||
doublecomplex z__1, z__2, z__3, z__4;
|
||||
|
||||
/* Builtin functions */
|
||||
void d_cnjg(doublecomplex *, doublecomplex *);
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
|
||||
doublecomplex temp1, temp2;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
integer kplus1;
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* ZHBMV performs the matrix-vector operation */
|
||||
|
||||
/* y := alpha*A*x + beta*y, */
|
||||
|
||||
/* where alpha and beta are scalars, x and y are n element vectors and */
|
||||
/* A is an n by n hermitian band matrix, with k super-diagonals. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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 - COMPLEX*16 . */
|
||||
/* On entry, ALPHA specifies the scalar alpha. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* A - COMPLEX*16 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 hermitian 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 hermitian 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 hermitian 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 hermitian 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 the imaginary parts of the diagonal elements need */
|
||||
/* not be set and are assumed to be zero. */
|
||||
/* 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 - COMPLEX*16 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 - COMPLEX*16 . */
|
||||
/* On entry, BETA specifies the scalar beta. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* Y - COMPLEX*16 array of DIMENSION at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCY ) ). */
|
||||
/* Before entry, the incremented array Y must contain the */
|
||||
/* 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
--y;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*k < 0) {
|
||||
info = 3;
|
||||
} else if (*lda < *k + 1) {
|
||||
info = 6;
|
||||
} else if (*incx == 0) {
|
||||
info = 8;
|
||||
} else if (*incy == 0) {
|
||||
info = 11;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("ZHBMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
|
||||
beta->i == 0.))) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Set up the start points in X and Y. */
|
||||
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} else {
|
||||
ky = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
|
||||
/* 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->r != 1. || beta->i != 0.) {
|
||||
if (*incy == 1) {
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = i__;
|
||||
y[i__2].r = 0., y[i__2].i = 0.;
|
||||
/* L10: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = i__;
|
||||
i__3 = i__;
|
||||
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
|
||||
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
|
||||
.r;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
/* L20: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iy = ky;
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = iy;
|
||||
y[i__2].r = 0., y[i__2].i = 0.;
|
||||
iy += *incy;
|
||||
/* L30: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = iy;
|
||||
i__3 = iy;
|
||||
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
|
||||
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
|
||||
.r;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
iy += *incy;
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (alpha->r == 0. && alpha->i == 0.) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form y when upper triangle of A is stored. */
|
||||
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = j;
|
||||
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = z__1.r, temp1.i = z__1.i;
|
||||
temp2.r = 0., temp2.i = 0.;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__2 = 1, i__3 = j - *k;
|
||||
i__4 = j - 1;
|
||||
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
|
||||
i__2 = i__;
|
||||
i__3 = i__;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
|
||||
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
|
||||
.r;
|
||||
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
|
||||
i__2 = i__;
|
||||
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, z__2.i =
|
||||
z__3.r * x[i__2].i + z__3.i * x[i__2].r;
|
||||
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
|
||||
temp2.r = z__1.r, temp2.i = z__1.i;
|
||||
/* L50: */
|
||||
}
|
||||
i__4 = j;
|
||||
i__2 = j;
|
||||
i__3 = kplus1 + j * a_dim1;
|
||||
d__1 = a[i__3].r;
|
||||
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
|
||||
z__2.r = y[i__2].r + z__3.r, z__2.i = y[i__2].i + z__3.i;
|
||||
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
|
||||
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__4 = jx;
|
||||
z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i =
|
||||
alpha->r * x[i__4].i + alpha->i * x[i__4].r;
|
||||
temp1.r = z__1.r, temp1.i = z__1.i;
|
||||
temp2.r = 0., temp2.i = 0.;
|
||||
ix = kx;
|
||||
iy = ky;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__2 = j - *k;
|
||||
i__3 = j - 1;
|
||||
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
|
||||
i__4 = iy;
|
||||
i__2 = iy;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
|
||||
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
|
||||
.r;
|
||||
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
|
||||
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
|
||||
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = ix;
|
||||
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
|
||||
z__3.r * x[i__4].i + z__3.i * x[i__4].r;
|
||||
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
|
||||
temp2.r = z__1.r, temp2.i = z__1.i;
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
/* L70: */
|
||||
}
|
||||
i__3 = jy;
|
||||
i__4 = jy;
|
||||
i__2 = kplus1 + j * a_dim1;
|
||||
d__1 = a[i__2].r;
|
||||
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
|
||||
z__2.r = y[i__4].r + z__3.r, z__2.i = y[i__4].i + z__3.i;
|
||||
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
if (j > *k) {
|
||||
kx += *incx;
|
||||
ky += *incy;
|
||||
}
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form y when lower triangle of A is stored. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__3 = j;
|
||||
z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
|
||||
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
|
||||
temp1.r = z__1.r, temp1.i = z__1.i;
|
||||
temp2.r = 0., temp2.i = 0.;
|
||||
i__3 = j;
|
||||
i__4 = j;
|
||||
i__2 = j * a_dim1 + 1;
|
||||
d__1 = a[i__2].r;
|
||||
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
|
||||
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__2 = j + *k;
|
||||
i__3 = min(i__4,i__2);
|
||||
for (i__ = j + 1; i__ <= i__3; ++i__) {
|
||||
i__4 = i__;
|
||||
i__2 = i__;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
|
||||
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
|
||||
.r;
|
||||
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
|
||||
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
|
||||
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = i__;
|
||||
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
|
||||
z__3.r * x[i__4].i + z__3.i * x[i__4].r;
|
||||
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
|
||||
temp2.r = z__1.r, temp2.i = z__1.i;
|
||||
/* L90: */
|
||||
}
|
||||
i__3 = j;
|
||||
i__4 = j;
|
||||
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__3 = jx;
|
||||
z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
|
||||
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
|
||||
temp1.r = z__1.r, temp1.i = z__1.i;
|
||||
temp2.r = 0., temp2.i = 0.;
|
||||
i__3 = jy;
|
||||
i__4 = jy;
|
||||
i__2 = j * a_dim1 + 1;
|
||||
d__1 = a[i__2].r;
|
||||
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
|
||||
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
l = 1 - j;
|
||||
ix = jx;
|
||||
iy = jy;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__2 = j + *k;
|
||||
i__3 = min(i__4,i__2);
|
||||
for (i__ = j + 1; i__ <= i__3; ++i__) {
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
i__4 = iy;
|
||||
i__2 = iy;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
|
||||
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
|
||||
.r;
|
||||
z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
|
||||
y[i__4].r = z__1.r, y[i__4].i = z__1.i;
|
||||
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = ix;
|
||||
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
|
||||
z__3.r * x[i__4].i + z__3.i * x[i__4].r;
|
||||
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
|
||||
temp2.r = z__1.r, temp2.i = z__1.i;
|
||||
/* L110: */
|
||||
}
|
||||
i__3 = jy;
|
||||
i__4 = jy;
|
||||
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of ZHBMV . */
|
||||
|
||||
} /* zhbmv_ */
|
||||
|
||||
438
blas/f2c/zhpmv.c
Normal file
438
blas/f2c/zhpmv.c
Normal file
@@ -0,0 +1,438 @@
|
||||
/* zhpmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int zhpmv_(char *uplo, integer *n, doublecomplex *alpha,
|
||||
doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex *
|
||||
beta, doublecomplex *y, integer *incy, ftnlen uplo_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer i__1, i__2, i__3, i__4, i__5;
|
||||
doublereal d__1;
|
||||
doublecomplex z__1, z__2, z__3, z__4;
|
||||
|
||||
/* Builtin functions */
|
||||
void d_cnjg(doublecomplex *, doublecomplex *);
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
|
||||
doublecomplex temp1, temp2;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* ZHPMV performs the matrix-vector operation */
|
||||
|
||||
/* y := alpha*A*x + beta*y, */
|
||||
|
||||
/* where alpha and beta are scalars, x and y are n element vectors and */
|
||||
/* A is an n by n hermitian matrix, supplied in packed form. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* UPLO - CHARACTER*1. */
|
||||
/* On entry, UPLO specifies whether the upper or lower */
|
||||
/* triangular part of the matrix A is supplied in the packed */
|
||||
/* array AP as follows: */
|
||||
|
||||
/* UPLO = 'U' or 'u' The upper triangular part of A is */
|
||||
/* supplied in AP. */
|
||||
|
||||
/* UPLO = 'L' or 'l' The lower triangular part of A is */
|
||||
/* supplied in AP. */
|
||||
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* N - INTEGER. */
|
||||
/* On entry, N specifies the order of the matrix A. */
|
||||
/* N must be at least zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* ALPHA - COMPLEX*16 . */
|
||||
/* On entry, ALPHA specifies the scalar alpha. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* AP - COMPLEX*16 array of DIMENSION at least */
|
||||
/* ( ( n*( n + 1 ) )/2 ). */
|
||||
/* Before entry with UPLO = 'U' or 'u', the array AP must */
|
||||
/* contain the upper triangular part of the hermitian matrix */
|
||||
/* packed sequentially, column by column, so that AP( 1 ) */
|
||||
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
|
||||
/* and a( 2, 2 ) respectively, and so on. */
|
||||
/* Before entry with UPLO = 'L' or 'l', the array AP must */
|
||||
/* contain the lower triangular part of the hermitian matrix */
|
||||
/* packed sequentially, column by column, so that AP( 1 ) */
|
||||
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
|
||||
/* and a( 3, 1 ) respectively, and so on. */
|
||||
/* Note that the imaginary parts of the diagonal elements need */
|
||||
/* not be set and are assumed to be zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* X - COMPLEX*16 array of dimension at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
|
||||
/* Before entry, the incremented array X must contain the n */
|
||||
/* element vector x. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* INCX - INTEGER. */
|
||||
/* On entry, INCX specifies the increment for the elements of */
|
||||
/* X. INCX must not be zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* BETA - COMPLEX*16 . */
|
||||
/* On entry, BETA specifies the scalar beta. When BETA is */
|
||||
/* supplied as zero then Y need not be set on input. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* Y - COMPLEX*16 array of dimension at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCY ) ). */
|
||||
/* Before entry, the incremented array Y must contain the n */
|
||||
/* element vector y. On exit, Y is overwritten by the updated */
|
||||
/* vector y. */
|
||||
|
||||
/* INCY - INTEGER. */
|
||||
/* On entry, INCY specifies the increment for the elements of */
|
||||
/* Y. INCY must not be zero. */
|
||||
/* Unchanged on exit. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--y;
|
||||
--x;
|
||||
--ap;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (*n < 0) {
|
||||
info = 2;
|
||||
} else if (*incx == 0) {
|
||||
info = 6;
|
||||
} else if (*incy == 0) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("ZHPMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
|
||||
beta->i == 0.))) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Set up the start points in X and Y. */
|
||||
|
||||
if (*incx > 0) {
|
||||
kx = 1;
|
||||
} else {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
}
|
||||
if (*incy > 0) {
|
||||
ky = 1;
|
||||
} else {
|
||||
ky = 1 - (*n - 1) * *incy;
|
||||
}
|
||||
|
||||
/* 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->r != 1. || beta->i != 0.) {
|
||||
if (*incy == 1) {
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = i__;
|
||||
y[i__2].r = 0., y[i__2].i = 0.;
|
||||
/* L10: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = i__;
|
||||
i__3 = i__;
|
||||
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
|
||||
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
|
||||
.r;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
/* L20: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iy = ky;
|
||||
if (beta->r == 0. && beta->i == 0.) {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = iy;
|
||||
y[i__2].r = 0., y[i__2].i = 0.;
|
||||
iy += *incy;
|
||||
/* L30: */
|
||||
}
|
||||
} else {
|
||||
i__1 = *n;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
i__2 = iy;
|
||||
i__3 = iy;
|
||||
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
|
||||
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
|
||||
.r;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
iy += *incy;
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (alpha->r == 0. && alpha->i == 0.) {
|
||||
return 0;
|
||||
}
|
||||
kk = 1;
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form y when AP contains the upper triangle. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = j;
|
||||
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = z__1.r, temp1.i = z__1.i;
|
||||
temp2.r = 0., temp2.i = 0.;
|
||||
k = kk;
|
||||
i__2 = j - 1;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__;
|
||||
i__4 = i__;
|
||||
i__5 = k;
|
||||
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
|
||||
z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
|
||||
.r;
|
||||
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
d_cnjg(&z__3, &ap[k]);
|
||||
i__3 = i__;
|
||||
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
|
||||
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
|
||||
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
|
||||
temp2.r = z__1.r, temp2.i = z__1.i;
|
||||
++k;
|
||||
/* L50: */
|
||||
}
|
||||
i__2 = j;
|
||||
i__3 = j;
|
||||
i__4 = kk + j - 1;
|
||||
d__1 = ap[i__4].r;
|
||||
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
|
||||
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
|
||||
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
kk += j;
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = jx;
|
||||
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = z__1.r, temp1.i = z__1.i;
|
||||
temp2.r = 0., temp2.i = 0.;
|
||||
ix = kx;
|
||||
iy = ky;
|
||||
i__2 = kk + j - 2;
|
||||
for (k = kk; k <= i__2; ++k) {
|
||||
i__3 = iy;
|
||||
i__4 = iy;
|
||||
i__5 = k;
|
||||
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
|
||||
z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
|
||||
.r;
|
||||
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
d_cnjg(&z__3, &ap[k]);
|
||||
i__3 = ix;
|
||||
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
|
||||
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
|
||||
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
|
||||
temp2.r = z__1.r, temp2.i = z__1.i;
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
/* L70: */
|
||||
}
|
||||
i__2 = jy;
|
||||
i__3 = jy;
|
||||
i__4 = kk + j - 1;
|
||||
d__1 = ap[i__4].r;
|
||||
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
|
||||
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
|
||||
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
kk += j;
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form y when AP contains the lower triangle. */
|
||||
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = j;
|
||||
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = z__1.r, temp1.i = z__1.i;
|
||||
temp2.r = 0., temp2.i = 0.;
|
||||
i__2 = j;
|
||||
i__3 = j;
|
||||
i__4 = kk;
|
||||
d__1 = ap[i__4].r;
|
||||
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
|
||||
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
k = kk + 1;
|
||||
i__2 = *n;
|
||||
for (i__ = j + 1; i__ <= i__2; ++i__) {
|
||||
i__3 = i__;
|
||||
i__4 = i__;
|
||||
i__5 = k;
|
||||
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
|
||||
z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
|
||||
.r;
|
||||
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
d_cnjg(&z__3, &ap[k]);
|
||||
i__3 = i__;
|
||||
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
|
||||
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
|
||||
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
|
||||
temp2.r = z__1.r, temp2.i = z__1.i;
|
||||
++k;
|
||||
/* L90: */
|
||||
}
|
||||
i__2 = j;
|
||||
i__3 = j;
|
||||
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
kk += *n - j + 1;
|
||||
/* L100: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
jy = ky;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = jx;
|
||||
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
|
||||
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
|
||||
temp1.r = z__1.r, temp1.i = z__1.i;
|
||||
temp2.r = 0., temp2.i = 0.;
|
||||
i__2 = jy;
|
||||
i__3 = jy;
|
||||
i__4 = kk;
|
||||
d__1 = ap[i__4].r;
|
||||
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
|
||||
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
ix = jx;
|
||||
iy = jy;
|
||||
i__2 = kk + *n - j;
|
||||
for (k = kk + 1; k <= i__2; ++k) {
|
||||
ix += *incx;
|
||||
iy += *incy;
|
||||
i__3 = iy;
|
||||
i__4 = iy;
|
||||
i__5 = k;
|
||||
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
|
||||
z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
|
||||
.r;
|
||||
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
|
||||
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
|
||||
d_cnjg(&z__3, &ap[k]);
|
||||
i__3 = ix;
|
||||
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
|
||||
z__3.r * x[i__3].i + z__3.i * x[i__3].r;
|
||||
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
|
||||
temp2.r = z__1.r, temp2.i = z__1.i;
|
||||
/* L110: */
|
||||
}
|
||||
i__2 = jy;
|
||||
i__3 = jy;
|
||||
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
|
||||
alpha->r * temp2.i + alpha->i * temp2.r;
|
||||
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
|
||||
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
|
||||
jx += *incx;
|
||||
jy += *incy;
|
||||
kk += *n - j + 1;
|
||||
/* L120: */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of ZHPMV . */
|
||||
|
||||
} /* zhpmv_ */
|
||||
|
||||
647
blas/f2c/ztbmv.c
Normal file
647
blas/f2c/ztbmv.c
Normal file
@@ -0,0 +1,647 @@
|
||||
/* ztbmv.f -- translated by f2c (version 20100827).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "datatypes.h"
|
||||
|
||||
/* Subroutine */ int ztbmv_(char *uplo, char *trans, char *diag, integer *n,
|
||||
integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer
|
||||
*incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
|
||||
{
|
||||
/* System generated locals */
|
||||
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
|
||||
doublecomplex z__1, z__2, z__3;
|
||||
|
||||
/* Builtin functions */
|
||||
void d_cnjg(doublecomplex *, doublecomplex *);
|
||||
|
||||
/* Local variables */
|
||||
integer i__, j, l, ix, jx, kx, info;
|
||||
doublecomplex temp;
|
||||
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
||||
integer kplus1;
|
||||
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
|
||||
logical noconj, nounit;
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
/* .. Array Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* ZTBMV performs one of the matrix-vector operations */
|
||||
|
||||
/* x := A*x, or x := A'*x, or x := conjg( 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. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========== */
|
||||
|
||||
/* 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 := conjg( 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 - COMPLEX*16 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 - COMPLEX*16 array of dimension at least */
|
||||
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
|
||||
/* Before entry, the incremented array X must contain the n */
|
||||
/* element vector x. 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. */
|
||||
|
||||
/* Further Details */
|
||||
/* =============== */
|
||||
|
||||
/* 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 .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
/* .. External Functions .. */
|
||||
/* .. */
|
||||
/* .. External Subroutines .. */
|
||||
/* .. */
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
|
||||
/* Test the input parameters. */
|
||||
|
||||
/* Parameter adjustments */
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--x;
|
||||
|
||||
/* Function Body */
|
||||
info = 0;
|
||||
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
|
||||
ftnlen)1, (ftnlen)1)) {
|
||||
info = 1;
|
||||
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
|
||||
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
|
||||
ftnlen)1)) {
|
||||
info = 2;
|
||||
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
|
||||
"N", (ftnlen)1, (ftnlen)1)) {
|
||||
info = 3;
|
||||
} else if (*n < 0) {
|
||||
info = 4;
|
||||
} else if (*k < 0) {
|
||||
info = 5;
|
||||
} else if (*lda < *k + 1) {
|
||||
info = 7;
|
||||
} else if (*incx == 0) {
|
||||
info = 9;
|
||||
}
|
||||
if (info != 0) {
|
||||
xerbla_("ZTBMV ", &info, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Quick return if possible. */
|
||||
|
||||
if (*n == 0) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
|
||||
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
|
||||
|
||||
/* 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 <= 0) {
|
||||
kx = 1 - (*n - 1) * *incx;
|
||||
} else if (*incx != 1) {
|
||||
kx = 1;
|
||||
}
|
||||
|
||||
/* Start the operations. In this version the elements of A are */
|
||||
/* accessed sequentially with one pass through A. */
|
||||
|
||||
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
|
||||
|
||||
/* Form x := A*x. */
|
||||
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = j;
|
||||
if (x[i__2].r != 0. || x[i__2].i != 0.) {
|
||||
i__2 = j;
|
||||
temp.r = x[i__2].r, temp.i = x[i__2].i;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__2 = 1, i__3 = j - *k;
|
||||
i__4 = j - 1;
|
||||
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
|
||||
i__2 = i__;
|
||||
i__3 = i__;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
|
||||
z__2.i = temp.r * a[i__5].i + temp.i * a[
|
||||
i__5].r;
|
||||
z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
|
||||
z__2.i;
|
||||
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
|
||||
/* L10: */
|
||||
}
|
||||
if (nounit) {
|
||||
i__4 = j;
|
||||
i__2 = j;
|
||||
i__3 = kplus1 + j * a_dim1;
|
||||
z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
|
||||
i__3].i, z__1.i = x[i__2].r * a[i__3].i +
|
||||
x[i__2].i * a[i__3].r;
|
||||
x[i__4].r = z__1.r, x[i__4].i = z__1.i;
|
||||
}
|
||||
}
|
||||
/* L20: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__4 = jx;
|
||||
if (x[i__4].r != 0. || x[i__4].i != 0.) {
|
||||
i__4 = jx;
|
||||
temp.r = x[i__4].r, temp.i = x[i__4].i;
|
||||
ix = kx;
|
||||
l = kplus1 - j;
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__2 = j - *k;
|
||||
i__3 = j - 1;
|
||||
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
|
||||
i__4 = ix;
|
||||
i__2 = ix;
|
||||
i__5 = l + i__ + j * a_dim1;
|
||||
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
|
||||
z__2.i = temp.r * a[i__5].i + temp.i * a[
|
||||
i__5].r;
|
||||
z__1.r = x[i__2].r + z__2.r, z__1.i = x[i__2].i +
|
||||
z__2.i;
|
||||
x[i__4].r = z__1.r, x[i__4].i = z__1.i;
|
||||
ix += *incx;
|
||||
/* L30: */
|
||||
}
|
||||
if (nounit) {
|
||||
i__3 = jx;
|
||||
i__4 = jx;
|
||||
i__2 = kplus1 + j * a_dim1;
|
||||
z__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[
|
||||
i__2].i, z__1.i = x[i__4].r * a[i__2].i +
|
||||
x[i__4].i * a[i__2].r;
|
||||
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
|
||||
}
|
||||
}
|
||||
jx += *incx;
|
||||
if (j > *k) {
|
||||
kx += *incx;
|
||||
}
|
||||
/* L40: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
i__1 = j;
|
||||
if (x[i__1].r != 0. || x[i__1].i != 0.) {
|
||||
i__1 = j;
|
||||
temp.r = x[i__1].r, temp.i = x[i__1].i;
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__3 = j + *k;
|
||||
i__4 = j + 1;
|
||||
for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
|
||||
i__1 = i__;
|
||||
i__3 = i__;
|
||||
i__2 = l + i__ + j * a_dim1;
|
||||
z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
|
||||
z__2.i = temp.r * a[i__2].i + temp.i * a[
|
||||
i__2].r;
|
||||
z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
|
||||
z__2.i;
|
||||
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
|
||||
/* L50: */
|
||||
}
|
||||
if (nounit) {
|
||||
i__4 = j;
|
||||
i__1 = j;
|
||||
i__3 = j * a_dim1 + 1;
|
||||
z__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[
|
||||
i__3].i, z__1.i = x[i__1].r * a[i__3].i +
|
||||
x[i__1].i * a[i__3].r;
|
||||
x[i__4].r = z__1.r, x[i__4].i = z__1.i;
|
||||
}
|
||||
}
|
||||
/* L60: */
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
i__4 = jx;
|
||||
if (x[i__4].r != 0. || x[i__4].i != 0.) {
|
||||
i__4 = jx;
|
||||
temp.r = x[i__4].r, temp.i = x[i__4].i;
|
||||
ix = kx;
|
||||
l = 1 - j;
|
||||
/* Computing MIN */
|
||||
i__4 = *n, i__1 = j + *k;
|
||||
i__3 = j + 1;
|
||||
for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
|
||||
i__4 = ix;
|
||||
i__1 = ix;
|
||||
i__2 = l + i__ + j * a_dim1;
|
||||
z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
|
||||
z__2.i = temp.r * a[i__2].i + temp.i * a[
|
||||
i__2].r;
|
||||
z__1.r = x[i__1].r + z__2.r, z__1.i = x[i__1].i +
|
||||
z__2.i;
|
||||
x[i__4].r = z__1.r, x[i__4].i = z__1.i;
|
||||
ix -= *incx;
|
||||
/* L70: */
|
||||
}
|
||||
if (nounit) {
|
||||
i__3 = jx;
|
||||
i__4 = jx;
|
||||
i__1 = j * a_dim1 + 1;
|
||||
z__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[
|
||||
i__1].i, z__1.i = x[i__4].r * a[i__1].i +
|
||||
x[i__4].i * a[i__1].r;
|
||||
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
|
||||
}
|
||||
}
|
||||
jx -= *incx;
|
||||
if (*n - j >= *k) {
|
||||
kx -= *incx;
|
||||
}
|
||||
/* L80: */
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
|
||||
/* Form x := A'*x or x := conjg( A' )*x. */
|
||||
|
||||
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
|
||||
kplus1 = *k + 1;
|
||||
if (*incx == 1) {
|
||||
for (j = *n; j >= 1; --j) {
|
||||
i__3 = j;
|
||||
temp.r = x[i__3].r, temp.i = x[i__3].i;
|
||||
l = kplus1 - j;
|
||||
if (noconj) {
|
||||
if (nounit) {
|
||||
i__3 = kplus1 + j * a_dim1;
|
||||
z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
|
||||
z__1.i = temp.r * a[i__3].i + temp.i * a[
|
||||
i__3].r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
i__4 = l + i__ + j * a_dim1;
|
||||
i__1 = i__;
|
||||
z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
|
||||
i__1].i, z__2.i = a[i__4].r * x[i__1].i +
|
||||
a[i__4].i * x[i__1].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
|
||||
z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
/* L90: */
|
||||
}
|
||||
} else {
|
||||
if (nounit) {
|
||||
d_cnjg(&z__2, &a[kplus1 + j * a_dim1]);
|
||||
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
|
||||
z__1.i = temp.r * z__2.i + temp.i *
|
||||
z__2.r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = i__;
|
||||
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
|
||||
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
|
||||
i__4].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
|
||||
z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
/* L100: */
|
||||
}
|
||||
}
|
||||
i__3 = j;
|
||||
x[i__3].r = temp.r, x[i__3].i = temp.i;
|
||||
/* L110: */
|
||||
}
|
||||
} else {
|
||||
kx += (*n - 1) * *incx;
|
||||
jx = kx;
|
||||
for (j = *n; j >= 1; --j) {
|
||||
i__3 = jx;
|
||||
temp.r = x[i__3].r, temp.i = x[i__3].i;
|
||||
kx -= *incx;
|
||||
ix = kx;
|
||||
l = kplus1 - j;
|
||||
if (noconj) {
|
||||
if (nounit) {
|
||||
i__3 = kplus1 + j * a_dim1;
|
||||
z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
|
||||
z__1.i = temp.r * a[i__3].i + temp.i * a[
|
||||
i__3].r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
i__4 = l + i__ + j * a_dim1;
|
||||
i__1 = ix;
|
||||
z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
|
||||
i__1].i, z__2.i = a[i__4].r * x[i__1].i +
|
||||
a[i__4].i * x[i__1].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
|
||||
z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
ix -= *incx;
|
||||
/* L120: */
|
||||
}
|
||||
} else {
|
||||
if (nounit) {
|
||||
d_cnjg(&z__2, &a[kplus1 + j * a_dim1]);
|
||||
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
|
||||
z__1.i = temp.r * z__2.i + temp.i *
|
||||
z__2.r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
}
|
||||
/* Computing MAX */
|
||||
i__4 = 1, i__1 = j - *k;
|
||||
i__3 = max(i__4,i__1);
|
||||
for (i__ = j - 1; i__ >= i__3; --i__) {
|
||||
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
|
||||
i__4 = ix;
|
||||
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
|
||||
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
|
||||
i__4].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
|
||||
z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
ix -= *incx;
|
||||
/* L130: */
|
||||
}
|
||||
}
|
||||
i__3 = jx;
|
||||
x[i__3].r = temp.r, x[i__3].i = temp.i;
|
||||
jx -= *incx;
|
||||
/* L140: */
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (*incx == 1) {
|
||||
i__3 = *n;
|
||||
for (j = 1; j <= i__3; ++j) {
|
||||
i__4 = j;
|
||||
temp.r = x[i__4].r, temp.i = x[i__4].i;
|
||||
l = 1 - j;
|
||||
if (noconj) {
|
||||
if (nounit) {
|
||||
i__4 = j * a_dim1 + 1;
|
||||
z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
|
||||
z__1.i = temp.r * a[i__4].i + temp.i * a[
|
||||
i__4].r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
i__1 = l + i__ + j * a_dim1;
|
||||
i__2 = i__;
|
||||
z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
|
||||
i__2].i, z__2.i = a[i__1].r * x[i__2].i +
|
||||
a[i__1].i * x[i__2].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
|
||||
z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
/* L150: */
|
||||
}
|
||||
} else {
|
||||
if (nounit) {
|
||||
d_cnjg(&z__2, &a[j * a_dim1 + 1]);
|
||||
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
|
||||
z__1.i = temp.r * z__2.i + temp.i *
|
||||
z__2.r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
|
||||
i__1 = i__;
|
||||
z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
|
||||
z__2.i = z__3.r * x[i__1].i + z__3.i * x[
|
||||
i__1].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
|
||||
z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
/* L160: */
|
||||
}
|
||||
}
|
||||
i__4 = j;
|
||||
x[i__4].r = temp.r, x[i__4].i = temp.i;
|
||||
/* L170: */
|
||||
}
|
||||
} else {
|
||||
jx = kx;
|
||||
i__3 = *n;
|
||||
for (j = 1; j <= i__3; ++j) {
|
||||
i__4 = jx;
|
||||
temp.r = x[i__4].r, temp.i = x[i__4].i;
|
||||
kx += *incx;
|
||||
ix = kx;
|
||||
l = 1 - j;
|
||||
if (noconj) {
|
||||
if (nounit) {
|
||||
i__4 = j * a_dim1 + 1;
|
||||
z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
|
||||
z__1.i = temp.r * a[i__4].i + temp.i * a[
|
||||
i__4].r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
i__1 = l + i__ + j * a_dim1;
|
||||
i__2 = ix;
|
||||
z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
|
||||
i__2].i, z__2.i = a[i__1].r * x[i__2].i +
|
||||
a[i__1].i * x[i__2].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
|
||||
z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
ix += *incx;
|
||||
/* L180: */
|
||||
}
|
||||
} else {
|
||||
if (nounit) {
|
||||
d_cnjg(&z__2, &a[j * a_dim1 + 1]);
|
||||
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
|
||||
z__1.i = temp.r * z__2.i + temp.i *
|
||||
z__2.r;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
}
|
||||
/* Computing MIN */
|
||||
i__1 = *n, i__2 = j + *k;
|
||||
i__4 = min(i__1,i__2);
|
||||
for (i__ = j + 1; i__ <= i__4; ++i__) {
|
||||
d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
|
||||
i__1 = ix;
|
||||
z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
|
||||
z__2.i = z__3.r * x[i__1].i + z__3.i * x[
|
||||
i__1].r;
|
||||
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
|
||||
z__2.i;
|
||||
temp.r = z__1.r, temp.i = z__1.i;
|
||||
ix += *incx;
|
||||
/* L190: */
|
||||
}
|
||||
}
|
||||
i__4 = jx;
|
||||
x[i__4].r = temp.r, x[i__4].i = temp.i;
|
||||
jx += *incx;
|
||||
/* L200: */
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
/* End of ZTBMV . */
|
||||
|
||||
} /* ztbmv_ */
|
||||
|
||||
85
blas/lsame.f
85
blas/lsame.f
@@ -1,85 +0,0 @@
|
||||
LOGICAL FUNCTION LSAME(CA,CB)
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.1) --
|
||||
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
|
||||
* November 2006
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER CA,CB
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* LSAME returns .TRUE. if CA is the same letter as CB regardless of
|
||||
* case.
|
||||
*
|
||||
* Arguments
|
||||
* =========
|
||||
*
|
||||
* CA (input) CHARACTER*1
|
||||
*
|
||||
* CB (input) CHARACTER*1
|
||||
* CA and CB specify the single characters to be compared.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ICHAR
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER INTA,INTB,ZCODE
|
||||
* ..
|
||||
*
|
||||
* Test if the characters are equal
|
||||
*
|
||||
LSAME = CA .EQ. CB
|
||||
IF (LSAME) RETURN
|
||||
*
|
||||
* Now test for equivalence if both characters are alphabetic.
|
||||
*
|
||||
ZCODE = ICHAR('Z')
|
||||
*
|
||||
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
|
||||
* machines, on which ICHAR returns a value with bit 8 set.
|
||||
* ICHAR('A') on Prime machines returns 193 which is the same as
|
||||
* ICHAR('A') on an EBCDIC machine.
|
||||
*
|
||||
INTA = ICHAR(CA)
|
||||
INTB = ICHAR(CB)
|
||||
*
|
||||
IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN
|
||||
*
|
||||
* ASCII is assumed - ZCODE is the ASCII code of either lower or
|
||||
* upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32
|
||||
IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32
|
||||
*
|
||||
ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN
|
||||
*
|
||||
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
|
||||
* upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.129 .AND. INTA.LE.137 .OR.
|
||||
+ INTA.GE.145 .AND. INTA.LE.153 .OR.
|
||||
+ INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64
|
||||
IF (INTB.GE.129 .AND. INTB.LE.137 .OR.
|
||||
+ INTB.GE.145 .AND. INTB.LE.153 .OR.
|
||||
+ INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64
|
||||
*
|
||||
ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN
|
||||
*
|
||||
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
|
||||
* plus 128 of either lower or upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32
|
||||
IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32
|
||||
END IF
|
||||
LSAME = INTA .EQ. INTB
|
||||
*
|
||||
* RETURN
|
||||
*
|
||||
* End of LSAME
|
||||
*
|
||||
END
|
||||
148
blas/srotm.f
148
blas/srotm.f
@@ -1,148 +0,0 @@
|
||||
SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SPARAM(5),SX(*),SY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
|
||||
*
|
||||
* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN
|
||||
* (DX**T)
|
||||
*
|
||||
* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
|
||||
* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY.
|
||||
* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
*
|
||||
* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
|
||||
*
|
||||
* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
|
||||
* H=( ) ( ) ( ) ( )
|
||||
* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
|
||||
* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM.
|
||||
*
|
||||
*
|
||||
* Arguments
|
||||
* =========
|
||||
*
|
||||
* N (input) INTEGER
|
||||
* number of elements in input vector(s)
|
||||
*
|
||||
* SX (input/output) REAL array, dimension N
|
||||
* double precision vector with N elements
|
||||
*
|
||||
* INCX (input) INTEGER
|
||||
* storage spacing between elements of SX
|
||||
*
|
||||
* SY (input/output) REAL array, dimension N
|
||||
* double precision vector with N elements
|
||||
*
|
||||
* INCY (input) INTEGER
|
||||
* storage spacing between elements of SY
|
||||
*
|
||||
* SPARAM (input/output) REAL array, dimension 5
|
||||
* SPARAM(1)=SFLAG
|
||||
* SPARAM(2)=SH11
|
||||
* SPARAM(3)=SH21
|
||||
* SPARAM(4)=SH12
|
||||
* SPARAM(5)=SH22
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO
|
||||
INTEGER I,KX,KY,NSTEPS
|
||||
* ..
|
||||
* .. Data statements ..
|
||||
DATA ZERO,TWO/0.E0,2.E0/
|
||||
* ..
|
||||
*
|
||||
SFLAG = SPARAM(1)
|
||||
IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) GO TO 140
|
||||
IF (.NOT. (INCX.EQ.INCY.AND.INCX.GT.0)) GO TO 70
|
||||
*
|
||||
NSTEPS = N*INCX
|
||||
IF (SFLAG) 50,10,30
|
||||
10 CONTINUE
|
||||
SH12 = SPARAM(4)
|
||||
SH21 = SPARAM(3)
|
||||
DO 20 I = 1,NSTEPS,INCX
|
||||
W = SX(I)
|
||||
Z = SY(I)
|
||||
SX(I) = W + Z*SH12
|
||||
SY(I) = W*SH21 + Z
|
||||
20 CONTINUE
|
||||
GO TO 140
|
||||
30 CONTINUE
|
||||
SH11 = SPARAM(2)
|
||||
SH22 = SPARAM(5)
|
||||
DO 40 I = 1,NSTEPS,INCX
|
||||
W = SX(I)
|
||||
Z = SY(I)
|
||||
SX(I) = W*SH11 + Z
|
||||
SY(I) = -W + SH22*Z
|
||||
40 CONTINUE
|
||||
GO TO 140
|
||||
50 CONTINUE
|
||||
SH11 = SPARAM(2)
|
||||
SH12 = SPARAM(4)
|
||||
SH21 = SPARAM(3)
|
||||
SH22 = SPARAM(5)
|
||||
DO 60 I = 1,NSTEPS,INCX
|
||||
W = SX(I)
|
||||
Z = SY(I)
|
||||
SX(I) = W*SH11 + Z*SH12
|
||||
SY(I) = W*SH21 + Z*SH22
|
||||
60 CONTINUE
|
||||
GO TO 140
|
||||
70 CONTINUE
|
||||
KX = 1
|
||||
KY = 1
|
||||
IF (INCX.LT.0) KX = 1 + (1-N)*INCX
|
||||
IF (INCY.LT.0) KY = 1 + (1-N)*INCY
|
||||
*
|
||||
IF (SFLAG) 120,80,100
|
||||
80 CONTINUE
|
||||
SH12 = SPARAM(4)
|
||||
SH21 = SPARAM(3)
|
||||
DO 90 I = 1,N
|
||||
W = SX(KX)
|
||||
Z = SY(KY)
|
||||
SX(KX) = W + Z*SH12
|
||||
SY(KY) = W*SH21 + Z
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
90 CONTINUE
|
||||
GO TO 140
|
||||
100 CONTINUE
|
||||
SH11 = SPARAM(2)
|
||||
SH22 = SPARAM(5)
|
||||
DO 110 I = 1,N
|
||||
W = SX(KX)
|
||||
Z = SY(KY)
|
||||
SX(KX) = W*SH11 + Z
|
||||
SY(KY) = -W + SH22*Z
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
110 CONTINUE
|
||||
GO TO 140
|
||||
120 CONTINUE
|
||||
SH11 = SPARAM(2)
|
||||
SH12 = SPARAM(4)
|
||||
SH21 = SPARAM(3)
|
||||
SH22 = SPARAM(5)
|
||||
DO 130 I = 1,N
|
||||
W = SX(KX)
|
||||
Z = SY(KY)
|
||||
SX(KX) = W*SH11 + Z*SH12
|
||||
SY(KY) = W*SH21 + Z*SH22
|
||||
KX = KX + INCX
|
||||
KY = KY + INCY
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
208
blas/srotmg.f
208
blas/srotmg.f
@@ -1,208 +0,0 @@
|
||||
SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
|
||||
* .. Scalar Arguments ..
|
||||
REAL SD1,SD2,SX1,SY1
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
REAL SPARAM(5)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
|
||||
* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*
|
||||
* SY2)**T.
|
||||
* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
||||
*
|
||||
* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
|
||||
*
|
||||
* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
|
||||
* H=( ) ( ) ( ) ( )
|
||||
* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
|
||||
* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
|
||||
* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
|
||||
* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
|
||||
*
|
||||
* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
|
||||
* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
|
||||
* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
|
||||
*
|
||||
*
|
||||
* Arguments
|
||||
* =========
|
||||
*
|
||||
*
|
||||
* SD1 (input/output) REAL
|
||||
*
|
||||
* SD2 (input/output) REAL
|
||||
*
|
||||
* SX1 (input/output) REAL
|
||||
*
|
||||
* SY1 (input) REAL
|
||||
*
|
||||
*
|
||||
* SPARAM (input/output) REAL array, dimension 5
|
||||
* SPARAM(1)=SFLAG
|
||||
* SPARAM(2)=SH11
|
||||
* SPARAM(3)=SH21
|
||||
* SPARAM(4)=SH12
|
||||
* SPARAM(5)=SH22
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
|
||||
+ SQ2,STEMP,SU,TWO,ZERO
|
||||
INTEGER IGO
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS
|
||||
* ..
|
||||
* .. Data statements ..
|
||||
*
|
||||
DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
|
||||
DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
|
||||
* ..
|
||||
|
||||
IF (.NOT.SD1.LT.ZERO) GO TO 10
|
||||
* GO ZERO-H-D-AND-SX1..
|
||||
GO TO 60
|
||||
10 CONTINUE
|
||||
* CASE-SD1-NONNEGATIVE
|
||||
SP2 = SD2*SY1
|
||||
IF (.NOT.SP2.EQ.ZERO) GO TO 20
|
||||
SFLAG = -TWO
|
||||
GO TO 260
|
||||
* REGULAR-CASE..
|
||||
20 CONTINUE
|
||||
SP1 = SD1*SX1
|
||||
SQ2 = SP2*SY1
|
||||
SQ1 = SP1*SX1
|
||||
*
|
||||
IF (.NOT.ABS(SQ1).GT.ABS(SQ2)) GO TO 40
|
||||
SH21 = -SY1/SX1
|
||||
SH12 = SP2/SP1
|
||||
*
|
||||
SU = ONE - SH12*SH21
|
||||
*
|
||||
IF (.NOT.SU.LE.ZERO) GO TO 30
|
||||
* GO ZERO-H-D-AND-SX1..
|
||||
GO TO 60
|
||||
30 CONTINUE
|
||||
SFLAG = ZERO
|
||||
SD1 = SD1/SU
|
||||
SD2 = SD2/SU
|
||||
SX1 = SX1*SU
|
||||
* GO SCALE-CHECK..
|
||||
GO TO 100
|
||||
40 CONTINUE
|
||||
IF (.NOT.SQ2.LT.ZERO) GO TO 50
|
||||
* GO ZERO-H-D-AND-SX1..
|
||||
GO TO 60
|
||||
50 CONTINUE
|
||||
SFLAG = ONE
|
||||
SH11 = SP1/SP2
|
||||
SH22 = SX1/SY1
|
||||
SU = ONE + SH11*SH22
|
||||
STEMP = SD2/SU
|
||||
SD2 = SD1/SU
|
||||
SD1 = STEMP
|
||||
SX1 = SY1*SU
|
||||
* GO SCALE-CHECK
|
||||
GO TO 100
|
||||
* PROCEDURE..ZERO-H-D-AND-SX1..
|
||||
60 CONTINUE
|
||||
SFLAG = -ONE
|
||||
SH11 = ZERO
|
||||
SH12 = ZERO
|
||||
SH21 = ZERO
|
||||
SH22 = ZERO
|
||||
*
|
||||
SD1 = ZERO
|
||||
SD2 = ZERO
|
||||
SX1 = ZERO
|
||||
* RETURN..
|
||||
GO TO 220
|
||||
* PROCEDURE..FIX-H..
|
||||
70 CONTINUE
|
||||
IF (.NOT.SFLAG.GE.ZERO) GO TO 90
|
||||
*
|
||||
IF (.NOT.SFLAG.EQ.ZERO) GO TO 80
|
||||
SH11 = ONE
|
||||
SH22 = ONE
|
||||
SFLAG = -ONE
|
||||
GO TO 90
|
||||
80 CONTINUE
|
||||
SH21 = -ONE
|
||||
SH12 = ONE
|
||||
SFLAG = -ONE
|
||||
90 CONTINUE
|
||||
GO TO IGO(120,150,180,210)
|
||||
* PROCEDURE..SCALE-CHECK
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
IF (.NOT.SD1.LE.RGAMSQ) GO TO 130
|
||||
IF (SD1.EQ.ZERO) GO TO 160
|
||||
ASSIGN 120 TO IGO
|
||||
* FIX-H..
|
||||
GO TO 70
|
||||
120 CONTINUE
|
||||
SD1 = SD1*GAM**2
|
||||
SX1 = SX1/GAM
|
||||
SH11 = SH11/GAM
|
||||
SH12 = SH12/GAM
|
||||
GO TO 110
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
IF (.NOT.SD1.GE.GAMSQ) GO TO 160
|
||||
ASSIGN 150 TO IGO
|
||||
* FIX-H..
|
||||
GO TO 70
|
||||
150 CONTINUE
|
||||
SD1 = SD1/GAM**2
|
||||
SX1 = SX1*GAM
|
||||
SH11 = SH11*GAM
|
||||
SH12 = SH12*GAM
|
||||
GO TO 140
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
IF (.NOT.ABS(SD2).LE.RGAMSQ) GO TO 190
|
||||
IF (SD2.EQ.ZERO) GO TO 220
|
||||
ASSIGN 180 TO IGO
|
||||
* FIX-H..
|
||||
GO TO 70
|
||||
180 CONTINUE
|
||||
SD2 = SD2*GAM**2
|
||||
SH21 = SH21/GAM
|
||||
SH22 = SH22/GAM
|
||||
GO TO 170
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
IF (.NOT.ABS(SD2).GE.GAMSQ) GO TO 220
|
||||
ASSIGN 210 TO IGO
|
||||
* FIX-H..
|
||||
GO TO 70
|
||||
210 CONTINUE
|
||||
SD2 = SD2/GAM**2
|
||||
SH21 = SH21*GAM
|
||||
SH22 = SH22*GAM
|
||||
GO TO 200
|
||||
220 CONTINUE
|
||||
IF (SFLAG) 250,230,240
|
||||
230 CONTINUE
|
||||
SPARAM(3) = SH21
|
||||
SPARAM(4) = SH12
|
||||
GO TO 260
|
||||
240 CONTINUE
|
||||
SPARAM(2) = SH11
|
||||
SPARAM(5) = SH22
|
||||
GO TO 260
|
||||
250 CONTINUE
|
||||
SPARAM(2) = SH11
|
||||
SPARAM(3) = SH21
|
||||
SPARAM(4) = SH12
|
||||
SPARAM(5) = SH22
|
||||
260 CONTINUE
|
||||
SPARAM(1) = SFLAG
|
||||
RETURN
|
||||
END
|
||||
306
blas/ssbmv.f
306
blas/ssbmv.f
@@ -1,306 +0,0 @@
|
||||
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 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.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* 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
|
||||
* ..
|
||||
*
|
||||
* 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
|
||||
265
blas/sspmv.f
265
blas/sspmv.f
@@ -1,265 +0,0 @@
|
||||
SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
REAL ALPHA,BETA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER 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.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* 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
|
||||
* ..
|
||||
*
|
||||
* 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
|
||||
335
blas/stbmv.f
335
blas/stbmv.f
@@ -1,335 +0,0 @@
|
||||
SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,K,LDA,N
|
||||
CHARACTER 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.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* 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
|
||||
* ..
|
||||
*
|
||||
* 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
|
||||
310
blas/zhbmv.f
310
blas/zhbmv.f
@@ -1,310 +0,0 @@
|
||||
SUBROUTINE ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,K,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE COMPLEX A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* ZHBMV performs the matrix-vector operation
|
||||
*
|
||||
* y := alpha*A*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are n element vectors and
|
||||
* A is an n by n hermitian band matrix, with k super-diagonals.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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 - COMPLEX*16 .
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - COMPLEX*16 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 hermitian 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 hermitian 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 hermitian 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 hermitian 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 the imaginary parts of the diagonal elements need
|
||||
* not be set and are assumed to be zero.
|
||||
* 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 - COMPLEX*16 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 - COMPLEX*16 .
|
||||
* On entry, BETA specifies the scalar beta.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - COMPLEX*16 array of DIMENSION at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the
|
||||
* 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0D+0,0.0D+0))
|
||||
DOUBLE COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE COMPLEX 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 DBLE,DCONJG,MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* 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('ZHBMV ',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 + DCONJG(A(L+I,J))*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*DBLE(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 + DCONJG(A(L+I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*DBLE(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*DBLE(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 + DCONJG(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*DBLE(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 + DCONJG(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 ZHBMV .
|
||||
*
|
||||
END
|
||||
272
blas/zhpmv.f
272
blas/zhpmv.f
@@ -1,272 +0,0 @@
|
||||
SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE COMPLEX ALPHA,BETA
|
||||
INTEGER INCX,INCY,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE COMPLEX AP(*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* ZHPMV performs the matrix-vector operation
|
||||
*
|
||||
* y := alpha*A*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are n element vectors and
|
||||
* A is an n by n hermitian matrix, supplied in packed form.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the matrix A is supplied in the packed
|
||||
* array AP as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' The upper triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* UPLO = 'L' or 'l' The lower triangular part of A is
|
||||
* supplied in AP.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - COMPLEX*16 .
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* AP - COMPLEX*16 array of DIMENSION at least
|
||||
* ( ( n*( n + 1 ) )/2 ).
|
||||
* Before entry with UPLO = 'U' or 'u', the array AP must
|
||||
* contain the upper triangular part of the hermitian matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
|
||||
* and a( 2, 2 ) respectively, and so on.
|
||||
* Before entry with UPLO = 'L' or 'l', the array AP must
|
||||
* contain the lower triangular part of the hermitian matrix
|
||||
* packed sequentially, column by column, so that AP( 1 )
|
||||
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
|
||||
* and a( 3, 1 ) respectively, and so on.
|
||||
* Note that the imaginary parts of the diagonal elements need
|
||||
* not be set and are assumed to be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - COMPLEX*16 array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - COMPLEX*16 .
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then Y need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - COMPLEX*16 array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the n
|
||||
* element vector y. On exit, Y is overwritten by the updated
|
||||
* vector y.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE COMPLEX ONE
|
||||
PARAMETER (ONE= (1.0D+0,0.0D+0))
|
||||
DOUBLE COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE COMPLEX TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE,DCONJG
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZHPMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of the array AP
|
||||
* are accessed sequentially with one pass through AP.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
KK = 1
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when AP contains the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
K = KK
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + DCONJG(AP(K))*X(I)
|
||||
K = K + 1
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*DBLE(AP(KK+J-1)) + ALPHA*TEMP2
|
||||
KK = KK + J
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 K = KK,KK + J - 2
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + DCONJG(AP(K))*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*DBLE(AP(KK+J-1)) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + J
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when AP contains the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*DBLE(AP(KK))
|
||||
K = KK + 1
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + DCONJG(AP(K))*X(I)
|
||||
K = K + 1
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
KK = KK + (N-J+1)
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*DBLE(AP(KK))
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 K = KK + 1,KK + N - J
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*AP(K)
|
||||
TEMP2 = TEMP2 + DCONJG(AP(K))*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
KK = KK + (N-J+1)
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZHPMV .
|
||||
*
|
||||
END
|
||||
366
blas/ztbmv.f
366
blas/ztbmv.f
@@ -1,366 +0,0 @@
|
||||
SUBROUTINE ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,K,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE COMPLEX A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* ZTBMV performs one of the matrix-vector operations
|
||||
*
|
||||
* x := A*x, or x := A'*x, or x := conjg( 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.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* 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 := conjg( 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 - COMPLEX*16 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 - COMPLEX*16 array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x. 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.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE COMPLEX ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE COMPLEX TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG,MAX,MIN
|
||||
* ..
|
||||
*
|
||||
* 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('ZTBMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
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 or x := conjg( A' )*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
KPLUS1 = K + 1
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
L = KPLUS1 - J
|
||||
IF (NOCONJ) THEN
|
||||
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
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(KPLUS1,J))
|
||||
DO 100 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + DCONJG(A(L+I,J))*X(I)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
KX = KX - INCX
|
||||
IX = KX
|
||||
L = KPLUS1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
|
||||
DO 120 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + A(L+I,J)*X(IX)
|
||||
IX = IX - INCX
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(KPLUS1,J))
|
||||
DO 130 I = J - 1,MAX(1,J-K),-1
|
||||
TEMP = TEMP + DCONJG(A(L+I,J))*X(IX)
|
||||
IX = IX - INCX
|
||||
130 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = 1,N
|
||||
TEMP = X(J)
|
||||
L = 1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(1,J)
|
||||
DO 150 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + A(L+I,J)*X(I)
|
||||
150 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(1,J))
|
||||
DO 160 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + DCONJG(A(L+I,J))*X(I)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 200 J = 1,N
|
||||
TEMP = X(JX)
|
||||
KX = KX + INCX
|
||||
IX = KX
|
||||
L = 1 - J
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(1,J)
|
||||
DO 180 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + A(L+I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(1,J))
|
||||
DO 190 I = J + 1,MIN(N,J+K)
|
||||
TEMP = TEMP + DCONJG(A(L+I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
190 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZTBMV .
|
||||
*
|
||||
END
|
||||
Reference in New Issue
Block a user