Squashed 'third_party/eigen/' changes from 61d72f6..cf794d3
Change-Id: I9b814151b01f49af6337a8605d0c42a3a1ed4c72
git-subtree-dir: third_party/eigen
git-subtree-split: cf794d3b741a6278df169e58461f8529f43bce5d
diff --git a/blas/CMakeLists.txt b/blas/CMakeLists.txt
index a9bc051..9887d58 100644
--- a/blas/CMakeLists.txt
+++ b/blas/CMakeLists.txt
@@ -14,23 +14,18 @@
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})
@@ -50,10 +45,12 @@
if(EIGEN_Fortran_COMPILER_WORKS)
-if(EIGEN_LEAVE_TEST_IN_ALL_TARGET)
- add_subdirectory(testing) # can't do EXCLUDE_FROM_ALL here, breaks CTest
-else()
- add_subdirectory(testing EXCLUDE_FROM_ALL)
+if(BUILD_TESTING)
+ if(EIGEN_LEAVE_TEST_IN_ALL_TARGET)
+ add_subdirectory(testing) # can't do EXCLUDE_FROM_ALL here, breaks CTest
+ else()
+ add_subdirectory(testing EXCLUDE_FROM_ALL)
+ endif()
endif()
endif()
diff --git a/blas/PackedTriangularMatrixVector.h b/blas/PackedTriangularMatrixVector.h
index e9886d5..0039536 100644
--- a/blas/PackedTriangularMatrixVector.h
+++ b/blas/PackedTriangularMatrixVector.h
@@ -18,7 +18,7 @@
template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar, bool ConjRhs>
struct packed_triangular_matrix_vector_product<Index,Mode,LhsScalar,ConjLhs,RhsScalar,ConjRhs,ColMajor>
{
- typedef typename scalar_product_traits<LhsScalar, RhsScalar>::ReturnType ResScalar;
+ typedef typename ScalarBinaryOpTraits<LhsScalar, RhsScalar>::ReturnType ResScalar;
enum {
IsLower = (Mode & Lower) ==Lower,
HasUnitDiag = (Mode & UnitDiag)==UnitDiag,
@@ -47,7 +47,7 @@
template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar, bool ConjRhs>
struct packed_triangular_matrix_vector_product<Index,Mode,LhsScalar,ConjLhs,RhsScalar,ConjRhs,RowMajor>
{
- typedef typename scalar_product_traits<LhsScalar, RhsScalar>::ReturnType ResScalar;
+ typedef typename ScalarBinaryOpTraits<LhsScalar, RhsScalar>::ReturnType ResScalar;
enum {
IsLower = (Mode & Lower) ==Lower,
HasUnitDiag = (Mode & UnitDiag)==UnitDiag,
diff --git a/blas/chbmv.f b/blas/chbmv.f
deleted file mode 100644
index 1b1c330..0000000
--- a/blas/chbmv.f
+++ /dev/null
@@ -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
diff --git a/blas/chpmv.f b/blas/chpmv.f
deleted file mode 100644
index 158be5a..0000000
--- a/blas/chpmv.f
+++ /dev/null
@@ -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
diff --git a/blas/common.h b/blas/common.h
index 2bf642c..61d8344 100644
--- a/blas/common.h
+++ b/blas/common.h
@@ -1,7 +1,7 @@
// This file is part of Eigen, a lightweight C++ template library
// for linear algebra.
//
-// Copyright (C) 2009-2010 Gael Guennebaud <gael.guennebaud@inria.fr>
+// Copyright (C) 2009-2015 Gael Guennebaud <gael.guennebaud@inria.fr>
//
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
@@ -10,18 +10,16 @@
#ifndef EIGEN_BLAS_COMMON_H
#define EIGEN_BLAS_COMMON_H
-#include <Eigen/Core>
-#include <Eigen/Jacobi>
+#include "../Eigen/Core"
+#include "../Eigen/Jacobi"
-#include <iostream>
#include <complex>
#ifndef SCALAR
#error the token SCALAR must be defined to compile this file
#endif
-#include <Eigen/src/misc/blas.h>
-
+#include "../Eigen/src/misc/blas.h"
#define NOTR 0
#define TR 1
@@ -95,6 +93,7 @@
typedef Matrix<Scalar,Dynamic,Dynamic,ColMajor> PlainMatrixType;
typedef Map<Matrix<Scalar,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> > MatrixType;
+typedef Map<const Matrix<Scalar,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> > ConstMatrixType;
typedef Map<Matrix<Scalar,Dynamic,1>, 0, InnerStride<Dynamic> > StridedVectorType;
typedef Map<Matrix<Scalar,Dynamic,1> > CompactVectorType;
@@ -106,26 +105,45 @@
}
template<typename T>
-Map<Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> > vector(T* data, int size, int incr)
+Map<const Matrix<T,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> >
+matrix(const T* data, int rows, int cols, int stride)
+{
+ return Map<const Matrix<T,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> >(data, rows, cols, OuterStride<>(stride));
+}
+
+template<typename T>
+Map<Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> > make_vector(T* data, int size, int incr)
{
return Map<Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> >(data, size, InnerStride<Dynamic>(incr));
}
template<typename T>
-Map<Matrix<T,Dynamic,1> > vector(T* data, int size)
+Map<const Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> > make_vector(const T* data, int size, int incr)
+{
+ return Map<const Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> >(data, size, InnerStride<Dynamic>(incr));
+}
+
+template<typename T>
+Map<Matrix<T,Dynamic,1> > make_vector(T* data, int size)
{
return Map<Matrix<T,Dynamic,1> >(data, size);
}
template<typename T>
+Map<const Matrix<T,Dynamic,1> > make_vector(const T* data, int size)
+{
+ return Map<const Matrix<T,Dynamic,1> >(data, size);
+}
+
+template<typename T>
T* get_compact_vector(T* x, int n, int incx)
{
if(incx==1)
return x;
- T* ret = new Scalar[n];
- if(incx<0) vector(ret,n) = vector(x,n,-incx).reverse();
- else vector(ret,n) = vector(x,n, incx);
+ typename Eigen::internal::remove_const<T>::type* ret = new Scalar[n];
+ if(incx<0) make_vector(ret,n) = make_vector(x,n,-incx).reverse();
+ else make_vector(ret,n) = make_vector(x,n, incx);
return ret;
}
@@ -135,8 +153,8 @@
if(x_cpy==x)
return 0;
- if(incx<0) vector(x,n,-incx).reverse() = vector(x_cpy,n);
- else vector(x,n, incx) = vector(x_cpy,n);
+ if(incx<0) make_vector(x,n,-incx).reverse() = make_vector(x_cpy,n);
+ else make_vector(x,n, incx) = make_vector(x_cpy,n);
return x_cpy;
}
diff --git a/blas/ctbmv.f b/blas/ctbmv.f
deleted file mode 100644
index 5a879fa..0000000
--- a/blas/ctbmv.f
+++ /dev/null
@@ -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
diff --git a/blas/double.cpp b/blas/double.cpp
index 8fd0709..295b1d1 100644
--- a/blas/double.cpp
+++ b/blas/double.cpp
@@ -23,11 +23,10 @@
{
if(*n<=0) return 0;
- if(*incx==1 && *incy==1) return (vector(x,*n).cast<double>().cwiseProduct(vector(y,*n).cast<double>())).sum();
- else if(*incx>0 && *incy>0) return (vector(x,*n,*incx).cast<double>().cwiseProduct(vector(y,*n,*incy).cast<double>())).sum();
- else if(*incx<0 && *incy>0) return (vector(x,*n,-*incx).reverse().cast<double>().cwiseProduct(vector(y,*n,*incy).cast<double>())).sum();
- else if(*incx>0 && *incy<0) return (vector(x,*n,*incx).cast<double>().cwiseProduct(vector(y,*n,-*incy).reverse().cast<double>())).sum();
- else if(*incx<0 && *incy<0) return (vector(x,*n,-*incx).reverse().cast<double>().cwiseProduct(vector(y,*n,-*incy).reverse().cast<double>())).sum();
+ if(*incx==1 && *incy==1) return (make_vector(x,*n).cast<double>().cwiseProduct(make_vector(y,*n).cast<double>())).sum();
+ else if(*incx>0 && *incy>0) return (make_vector(x,*n,*incx).cast<double>().cwiseProduct(make_vector(y,*n,*incy).cast<double>())).sum();
+ else if(*incx<0 && *incy>0) return (make_vector(x,*n,-*incx).reverse().cast<double>().cwiseProduct(make_vector(y,*n,*incy).cast<double>())).sum();
+ else if(*incx>0 && *incy<0) return (make_vector(x,*n,*incx).cast<double>().cwiseProduct(make_vector(y,*n,-*incy).reverse().cast<double>())).sum();
+ else if(*incx<0 && *incy<0) return (make_vector(x,*n,-*incx).reverse().cast<double>().cwiseProduct(make_vector(y,*n,-*incy).reverse().cast<double>())).sum();
else return 0;
}
-
diff --git a/blas/drotm.f b/blas/drotm.f
deleted file mode 100644
index 63a3b11..0000000
--- a/blas/drotm.f
+++ /dev/null
@@ -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
diff --git a/blas/drotmg.f b/blas/drotmg.f
deleted file mode 100644
index 3ae647b..0000000
--- a/blas/drotmg.f
+++ /dev/null
@@ -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
diff --git a/blas/dsbmv.f b/blas/dsbmv.f
deleted file mode 100644
index 8c82d1f..0000000
--- a/blas/dsbmv.f
+++ /dev/null
@@ -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
diff --git a/blas/dspmv.f b/blas/dspmv.f
deleted file mode 100644
index f6e121e..0000000
--- a/blas/dspmv.f
+++ /dev/null
@@ -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
diff --git a/blas/dtbmv.f b/blas/dtbmv.f
deleted file mode 100644
index a87ffde..0000000
--- a/blas/dtbmv.f
+++ /dev/null
@@ -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
diff --git a/blas/f2c/chbmv.c b/blas/f2c/chbmv.c
new file mode 100644
index 0000000..f218fe3
--- /dev/null
+++ b/blas/f2c/chbmv.c
@@ -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_ */
+
diff --git a/blas/f2c/chpmv.c b/blas/f2c/chpmv.c
new file mode 100644
index 0000000..65bab1c
--- /dev/null
+++ b/blas/f2c/chpmv.c
@@ -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_ */
+
diff --git a/blas/f2c/complexdots.c b/blas/f2c/complexdots.c
new file mode 100644
index 0000000..a856a23
--- /dev/null
+++ b/blas/f2c/complexdots.c
@@ -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_ */
+
diff --git a/blas/f2c/ctbmv.c b/blas/f2c/ctbmv.c
new file mode 100644
index 0000000..790fd58
--- /dev/null
+++ b/blas/f2c/ctbmv.c
@@ -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_ */
+
diff --git a/blas/f2c/d_cnjg.c b/blas/f2c/d_cnjg.c
new file mode 100644
index 0000000..623090c
--- /dev/null
+++ b/blas/f2c/d_cnjg.c
@@ -0,0 +1,6 @@
+#include "datatypes.h"
+
+void d_cnjg(doublecomplex *r, doublecomplex *z) {
+ r->r = z->r;
+ r->i = -(z->i);
+}
diff --git a/blas/f2c/datatypes.h b/blas/f2c/datatypes.h
new file mode 100644
index 0000000..63232b2
--- /dev/null
+++ b/blas/f2c/datatypes.h
@@ -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
diff --git a/blas/f2c/drotm.c b/blas/f2c/drotm.c
new file mode 100644
index 0000000..17a779b
--- /dev/null
+++ b/blas/f2c/drotm.c
@@ -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_ */
+
diff --git a/blas/f2c/drotmg.c b/blas/f2c/drotmg.c
new file mode 100644
index 0000000..a63eb10
--- /dev/null
+++ b/blas/f2c/drotmg.c
@@ -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_ */
+
diff --git a/blas/f2c/dsbmv.c b/blas/f2c/dsbmv.c
new file mode 100644
index 0000000..c6b4b21
--- /dev/null
+++ b/blas/f2c/dsbmv.c
@@ -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_ */
+
diff --git a/blas/f2c/dspmv.c b/blas/f2c/dspmv.c
new file mode 100644
index 0000000..0b4e92d
--- /dev/null
+++ b/blas/f2c/dspmv.c
@@ -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_ */
+
diff --git a/blas/f2c/dtbmv.c b/blas/f2c/dtbmv.c
new file mode 100644
index 0000000..fdf73eb
--- /dev/null
+++ b/blas/f2c/dtbmv.c
@@ -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_ */
+
diff --git a/blas/f2c/lsame.c b/blas/f2c/lsame.c
new file mode 100644
index 0000000..46324d9
--- /dev/null
+++ b/blas/f2c/lsame.c
@@ -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_ */
+
diff --git a/blas/f2c/r_cnjg.c b/blas/f2c/r_cnjg.c
new file mode 100644
index 0000000..c08182f
--- /dev/null
+++ b/blas/f2c/r_cnjg.c
@@ -0,0 +1,6 @@
+#include "datatypes.h"
+
+void r_cnjg(complex *r, complex *z) {
+ r->r = z->r;
+ r->i = -(z->i);
+}
diff --git a/blas/f2c/srotm.c b/blas/f2c/srotm.c
new file mode 100644
index 0000000..bd5944a
--- /dev/null
+++ b/blas/f2c/srotm.c
@@ -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_ */
+
diff --git a/blas/f2c/srotmg.c b/blas/f2c/srotmg.c
new file mode 100644
index 0000000..75f789f
--- /dev/null
+++ b/blas/f2c/srotmg.c
@@ -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_ */
+
diff --git a/blas/f2c/ssbmv.c b/blas/f2c/ssbmv.c
new file mode 100644
index 0000000..8599325
--- /dev/null
+++ b/blas/f2c/ssbmv.c
@@ -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_ */
+
diff --git a/blas/f2c/sspmv.c b/blas/f2c/sspmv.c
new file mode 100644
index 0000000..47858ec
--- /dev/null
+++ b/blas/f2c/sspmv.c
@@ -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_ */
+
diff --git a/blas/f2c/stbmv.c b/blas/f2c/stbmv.c
new file mode 100644
index 0000000..fcf9ce3
--- /dev/null
+++ b/blas/f2c/stbmv.c
@@ -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_ */
+
diff --git a/blas/f2c/zhbmv.c b/blas/f2c/zhbmv.c
new file mode 100644
index 0000000..42da13d
--- /dev/null
+++ b/blas/f2c/zhbmv.c
@@ -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_ */
+
diff --git a/blas/f2c/zhpmv.c b/blas/f2c/zhpmv.c
new file mode 100644
index 0000000..fbe2f42
--- /dev/null
+++ b/blas/f2c/zhpmv.c
@@ -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_ */
+
diff --git a/blas/f2c/ztbmv.c b/blas/f2c/ztbmv.c
new file mode 100644
index 0000000..4cdcd7f
--- /dev/null
+++ b/blas/f2c/ztbmv.c
@@ -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_ */
+
diff --git a/blas/complexdots.f b/blas/fortran/complexdots.f
similarity index 100%
rename from blas/complexdots.f
rename to blas/fortran/complexdots.f
diff --git a/blas/level1_cplx_impl.h b/blas/level1_cplx_impl.h
index 283b9f8..719f5ba 100644
--- a/blas/level1_cplx_impl.h
+++ b/blas/level1_cplx_impl.h
@@ -32,45 +32,52 @@
if(*n<=0) return 0;
- if(*incx==1) return vector(x,*n).unaryExpr<scalar_norm1_op>().sum();
- else return vector(x,*n,std::abs(*incx)).unaryExpr<scalar_norm1_op>().sum();
+ if(*incx==1) return make_vector(x,*n).unaryExpr<scalar_norm1_op>().sum();
+ else return make_vector(x,*n,std::abs(*incx)).unaryExpr<scalar_norm1_op>().sum();
}
// computes a dot product of a conjugated vector with another vector.
int EIGEN_BLAS_FUNC(dotcw)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar* pres)
{
// std::cerr << "_dotc " << *n << " " << *incx << " " << *incy << "\n";
+ Scalar* res = reinterpret_cast<Scalar*>(pres);
- if(*n<=0) return 0;
+ if(*n<=0)
+ {
+ *res = Scalar(0);
+ return 0;
+ }
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
- Scalar* res = reinterpret_cast<Scalar*>(pres);
- if(*incx==1 && *incy==1) *res = (vector(x,*n).dot(vector(y,*n)));
- else if(*incx>0 && *incy>0) *res = (vector(x,*n,*incx).dot(vector(y,*n,*incy)));
- else if(*incx<0 && *incy>0) *res = (vector(x,*n,-*incx).reverse().dot(vector(y,*n,*incy)));
- else if(*incx>0 && *incy<0) *res = (vector(x,*n,*incx).dot(vector(y,*n,-*incy).reverse()));
- else if(*incx<0 && *incy<0) *res = (vector(x,*n,-*incx).reverse().dot(vector(y,*n,-*incy).reverse()));
+ if(*incx==1 && *incy==1) *res = (make_vector(x,*n).dot(make_vector(y,*n)));
+ else if(*incx>0 && *incy>0) *res = (make_vector(x,*n,*incx).dot(make_vector(y,*n,*incy)));
+ else if(*incx<0 && *incy>0) *res = (make_vector(x,*n,-*incx).reverse().dot(make_vector(y,*n,*incy)));
+ else if(*incx>0 && *incy<0) *res = (make_vector(x,*n,*incx).dot(make_vector(y,*n,-*incy).reverse()));
+ else if(*incx<0 && *incy<0) *res = (make_vector(x,*n,-*incx).reverse().dot(make_vector(y,*n,-*incy).reverse()));
return 0;
}
// computes a vector-vector dot product without complex conjugation.
int EIGEN_BLAS_FUNC(dotuw)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar* pres)
{
-// std::cerr << "_dotu " << *n << " " << *incx << " " << *incy << "\n";
+ Scalar* res = reinterpret_cast<Scalar*>(pres);
- if(*n<=0) return 0;
+ if(*n<=0)
+ {
+ *res = Scalar(0);
+ return 0;
+ }
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
- Scalar* res = reinterpret_cast<Scalar*>(pres);
- if(*incx==1 && *incy==1) *res = (vector(x,*n).cwiseProduct(vector(y,*n))).sum();
- else if(*incx>0 && *incy>0) *res = (vector(x,*n,*incx).cwiseProduct(vector(y,*n,*incy))).sum();
- else if(*incx<0 && *incy>0) *res = (vector(x,*n,-*incx).reverse().cwiseProduct(vector(y,*n,*incy))).sum();
- else if(*incx>0 && *incy<0) *res = (vector(x,*n,*incx).cwiseProduct(vector(y,*n,-*incy).reverse())).sum();
- else if(*incx<0 && *incy<0) *res = (vector(x,*n,-*incx).reverse().cwiseProduct(vector(y,*n,-*incy).reverse())).sum();
+ if(*incx==1 && *incy==1) *res = (make_vector(x,*n).cwiseProduct(make_vector(y,*n))).sum();
+ else if(*incx>0 && *incy>0) *res = (make_vector(x,*n,*incx).cwiseProduct(make_vector(y,*n,*incy))).sum();
+ else if(*incx<0 && *incy>0) *res = (make_vector(x,*n,-*incx).reverse().cwiseProduct(make_vector(y,*n,*incy))).sum();
+ else if(*incx>0 && *incy<0) *res = (make_vector(x,*n,*incx).cwiseProduct(make_vector(y,*n,-*incy).reverse())).sum();
+ else if(*incx<0 && *incy<0) *res = (make_vector(x,*n,-*incx).reverse().cwiseProduct(make_vector(y,*n,-*incy).reverse())).sum();
return 0;
}
@@ -82,9 +89,9 @@
Scalar* x = reinterpret_cast<Scalar*>(px);
if(*incx==1)
- return vector(x,*n).stableNorm();
+ return make_vector(x,*n).stableNorm();
- return vector(x,*n,*incx).stableNorm();
+ return make_vector(x,*n,*incx).stableNorm();
}
int EIGEN_CAT(EIGEN_CAT(SCALAR_SUFFIX,REAL_SCALAR_SUFFIX),rot_)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pc, RealScalar *ps)
@@ -96,8 +103,8 @@
RealScalar c = *pc;
RealScalar s = *ps;
- StridedVectorType vx(vector(x,*n,std::abs(*incx)));
- StridedVectorType vy(vector(y,*n,std::abs(*incy)));
+ StridedVectorType vx(make_vector(x,*n,std::abs(*incx)));
+ StridedVectorType vy(make_vector(y,*n,std::abs(*incy)));
Reverse<StridedVectorType> rvx(vx);
Reverse<StridedVectorType> rvy(vy);
@@ -119,9 +126,8 @@
// std::cerr << "__scal " << *n << " " << alpha << " " << *incx << "\n";
- if(*incx==1) vector(x,*n) *= alpha;
- else vector(x,*n,std::abs(*incx)) *= alpha;
+ if(*incx==1) make_vector(x,*n) *= alpha;
+ else make_vector(x,*n,std::abs(*incx)) *= alpha;
return 0;
}
-
diff --git a/blas/level1_impl.h b/blas/level1_impl.h
index b08c2f6..f857bfa 100644
--- a/blas/level1_impl.h
+++ b/blas/level1_impl.h
@@ -9,19 +9,19 @@
#include "common.h"
-int EIGEN_BLAS_FUNC(axpy)(int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy)
+int EIGEN_BLAS_FUNC(axpy)(const int *n, const RealScalar *palpha, const RealScalar *px, const int *incx, RealScalar *py, const int *incy)
{
- Scalar* x = reinterpret_cast<Scalar*>(px);
+ const Scalar* x = reinterpret_cast<const Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
if(*n<=0) return 0;
- if(*incx==1 && *incy==1) vector(y,*n) += alpha * vector(x,*n);
- else if(*incx>0 && *incy>0) vector(y,*n,*incy) += alpha * vector(x,*n,*incx);
- else if(*incx>0 && *incy<0) vector(y,*n,-*incy).reverse() += alpha * vector(x,*n,*incx);
- else if(*incx<0 && *incy>0) vector(y,*n,*incy) += alpha * vector(x,*n,-*incx).reverse();
- else if(*incx<0 && *incy<0) vector(y,*n,-*incy).reverse() += alpha * vector(x,*n,-*incx).reverse();
+ if(*incx==1 && *incy==1) make_vector(y,*n) += alpha * make_vector(x,*n);
+ else if(*incx>0 && *incy>0) make_vector(y,*n,*incy) += alpha * make_vector(x,*n,*incx);
+ else if(*incx>0 && *incy<0) make_vector(y,*n,-*incy).reverse() += alpha * make_vector(x,*n,*incx);
+ else if(*incx<0 && *incy>0) make_vector(y,*n,*incy) += alpha * make_vector(x,*n,-*incx).reverse();
+ else if(*incx<0 && *incy<0) make_vector(y,*n,-*incy).reverse() += alpha * make_vector(x,*n,-*incx).reverse();
return 0;
}
@@ -35,7 +35,7 @@
// be carefull, *incx==0 is allowed !!
if(*incx==1 && *incy==1)
- vector(y,*n) = vector(x,*n);
+ make_vector(y,*n) = make_vector(x,*n);
else
{
if(*incx<0) x = x - (*n-1)*(*incx);
@@ -57,27 +57,27 @@
Scalar* x = reinterpret_cast<Scalar*>(px);
DenseIndex ret;
- if(*incx==1) vector(x,*n).cwiseAbs().maxCoeff(&ret);
- else vector(x,*n,std::abs(*incx)).cwiseAbs().maxCoeff(&ret);
- return ret+1;
+ if(*incx==1) make_vector(x,*n).cwiseAbs().maxCoeff(&ret);
+ else make_vector(x,*n,std::abs(*incx)).cwiseAbs().maxCoeff(&ret);
+ return int(ret)+1;
}
int EIGEN_CAT(EIGEN_CAT(i,SCALAR_SUFFIX),amin_)(int *n, RealScalar *px, int *incx)
{
if(*n<=0) return 0;
Scalar* x = reinterpret_cast<Scalar*>(px);
-
+
DenseIndex ret;
- if(*incx==1) vector(x,*n).cwiseAbs().minCoeff(&ret);
- else vector(x,*n,std::abs(*incx)).cwiseAbs().minCoeff(&ret);
- return ret+1;
+ if(*incx==1) make_vector(x,*n).cwiseAbs().minCoeff(&ret);
+ else make_vector(x,*n,std::abs(*incx)).cwiseAbs().minCoeff(&ret);
+ return int(ret)+1;
}
int EIGEN_BLAS_FUNC(rotg)(RealScalar *pa, RealScalar *pb, RealScalar *pc, RealScalar *ps)
{
using std::sqrt;
using std::abs;
-
+
Scalar& a = *reinterpret_cast<Scalar*>(pa);
Scalar& b = *reinterpret_cast<Scalar*>(pb);
RealScalar* c = pc;
@@ -143,8 +143,8 @@
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- if(*incx==1) vector(x,*n) *= alpha;
- else vector(x,*n,std::abs(*incx)) *= alpha;
+ if(*incx==1) make_vector(x,*n) *= alpha;
+ else make_vector(x,*n,std::abs(*incx)) *= alpha;
return 0;
}
@@ -156,12 +156,11 @@
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
- if(*incx==1 && *incy==1) vector(y,*n).swap(vector(x,*n));
- else if(*incx>0 && *incy>0) vector(y,*n,*incy).swap(vector(x,*n,*incx));
- else if(*incx>0 && *incy<0) vector(y,*n,-*incy).reverse().swap(vector(x,*n,*incx));
- else if(*incx<0 && *incy>0) vector(y,*n,*incy).swap(vector(x,*n,-*incx).reverse());
- else if(*incx<0 && *incy<0) vector(y,*n,-*incy).reverse().swap(vector(x,*n,-*incx).reverse());
+ if(*incx==1 && *incy==1) make_vector(y,*n).swap(make_vector(x,*n));
+ else if(*incx>0 && *incy>0) make_vector(y,*n,*incy).swap(make_vector(x,*n,*incx));
+ else if(*incx>0 && *incy<0) make_vector(y,*n,-*incy).reverse().swap(make_vector(x,*n,*incx));
+ else if(*incx<0 && *incy>0) make_vector(y,*n,*incy).swap(make_vector(x,*n,-*incx).reverse());
+ else if(*incx<0 && *incy<0) make_vector(y,*n,-*incy).reverse().swap(make_vector(x,*n,-*incx).reverse());
return 1;
}
-
diff --git a/blas/level1_real_impl.h b/blas/level1_real_impl.h
index 8acecdf..02586d5 100644
--- a/blas/level1_real_impl.h
+++ b/blas/level1_real_impl.h
@@ -19,8 +19,8 @@
if(*n<=0) return 0;
- if(*incx==1) return vector(x,*n).cwiseAbs().sum();
- else return vector(x,*n,std::abs(*incx)).cwiseAbs().sum();
+ if(*incx==1) return make_vector(x,*n).cwiseAbs().sum();
+ else return make_vector(x,*n,std::abs(*incx)).cwiseAbs().sum();
}
// computes a vector-vector dot product.
@@ -33,11 +33,11 @@
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
- if(*incx==1 && *incy==1) return (vector(x,*n).cwiseProduct(vector(y,*n))).sum();
- else if(*incx>0 && *incy>0) return (vector(x,*n,*incx).cwiseProduct(vector(y,*n,*incy))).sum();
- else if(*incx<0 && *incy>0) return (vector(x,*n,-*incx).reverse().cwiseProduct(vector(y,*n,*incy))).sum();
- else if(*incx>0 && *incy<0) return (vector(x,*n,*incx).cwiseProduct(vector(y,*n,-*incy).reverse())).sum();
- else if(*incx<0 && *incy<0) return (vector(x,*n,-*incx).reverse().cwiseProduct(vector(y,*n,-*incy).reverse())).sum();
+ if(*incx==1 && *incy==1) return (make_vector(x,*n).cwiseProduct(make_vector(y,*n))).sum();
+ else if(*incx>0 && *incy>0) return (make_vector(x,*n,*incx).cwiseProduct(make_vector(y,*n,*incy))).sum();
+ else if(*incx<0 && *incy>0) return (make_vector(x,*n,-*incx).reverse().cwiseProduct(make_vector(y,*n,*incy))).sum();
+ else if(*incx>0 && *incy<0) return (make_vector(x,*n,*incx).cwiseProduct(make_vector(y,*n,-*incy).reverse())).sum();
+ else if(*incx<0 && *incy<0) return (make_vector(x,*n,-*incx).reverse().cwiseProduct(make_vector(y,*n,-*incy).reverse())).sum();
else return 0;
}
@@ -50,8 +50,8 @@
Scalar* x = reinterpret_cast<Scalar*>(px);
- if(*incx==1) return vector(x,*n).stableNorm();
- else return vector(x,*n,std::abs(*incx)).stableNorm();
+ if(*incx==1) return make_vector(x,*n).stableNorm();
+ else return make_vector(x,*n,std::abs(*incx)).stableNorm();
}
int EIGEN_BLAS_FUNC(rot)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pc, RealScalar *ps)
@@ -64,8 +64,8 @@
Scalar c = *reinterpret_cast<Scalar*>(pc);
Scalar s = *reinterpret_cast<Scalar*>(ps);
- StridedVectorType vx(vector(x,*n,std::abs(*incx)));
- StridedVectorType vy(vector(y,*n,std::abs(*incy)));
+ StridedVectorType vx(make_vector(x,*n,std::abs(*incx)));
+ StridedVectorType vy(make_vector(y,*n,std::abs(*incy)));
Reverse<StridedVectorType> rvx(vx);
Reverse<StridedVectorType> rvy(vy);
diff --git a/blas/level2_cplx_impl.h b/blas/level2_cplx_impl.h
index b850b6c..e3ce614 100644
--- a/blas/level2_cplx_impl.h
+++ b/blas/level2_cplx_impl.h
@@ -16,28 +16,22 @@
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n hermitian matrix.
*/
-int EIGEN_BLAS_FUNC(hemv)(char *uplo, int *n, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *px, int *incx, RealScalar *pbeta, RealScalar *py, int *incy)
+int EIGEN_BLAS_FUNC(hemv)(const char *uplo, const int *n, const RealScalar *palpha, const RealScalar *pa, const int *lda,
+ const RealScalar *px, const int *incx, const RealScalar *pbeta, RealScalar *py, const int *incy)
{
- typedef void (*functype)(int, const Scalar*, int, const Scalar*, int, Scalar*, Scalar);
- static functype func[2];
+ typedef void (*functype)(int, const Scalar*, int, const Scalar*, Scalar*, Scalar);
+ static const functype func[2] = {
+ // array index: UP
+ (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Upper,false,false>::run),
+ // array index: LO
+ (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Lower,false,false>::run),
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Upper,false,false>::run);
- func[LO] = (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Lower,false,false>::run);
-
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* x = reinterpret_cast<Scalar*>(px);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* x = reinterpret_cast<const Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
// check arguments
int info = 0;
@@ -52,13 +46,13 @@
if(*n==0)
return 1;
- Scalar* actual_x = get_compact_vector(x,*n,*incx);
+ const Scalar* actual_x = get_compact_vector(x,*n,*incx);
Scalar* actual_y = get_compact_vector(y,*n,*incy);
if(beta!=Scalar(1))
{
- if(beta==Scalar(0)) vector(actual_y, *n).setZero();
- else vector(actual_y, *n) *= beta;
+ if(beta==Scalar(0)) make_vector(actual_y, *n).setZero();
+ else make_vector(actual_y, *n) *= beta;
}
if(alpha!=Scalar(0))
@@ -67,7 +61,7 @@
if(code>=2 || func[code]==0)
return 0;
- func[code](*n, a, *lda, actual_x, 1, actual_y, alpha);
+ func[code](*n, a, *lda, actual_x, actual_y, alpha);
}
if(actual_x!=x) delete[] actual_x;
@@ -111,19 +105,12 @@
int EIGEN_BLAS_FUNC(hpr)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *pap)
{
typedef void (*functype)(int, Scalar*, const Scalar*, RealScalar);
- static functype func[2];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run);
- func[LO] = (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run);
-
- init = true;
- }
+ static const functype func[2] = {
+ // array index: UP
+ (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run),
+ // array index: LO
+ (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run),
+ };
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* ap = reinterpret_cast<Scalar*>(pap);
@@ -162,19 +149,12 @@
int EIGEN_BLAS_FUNC(hpr2)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pap)
{
typedef void (*functype)(int, Scalar*, const Scalar*, const Scalar*, Scalar);
- static functype func[2];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (internal::packed_rank2_update_selector<Scalar,int,Upper>::run);
- func[LO] = (internal::packed_rank2_update_selector<Scalar,int,Lower>::run);
-
- init = true;
- }
+ static const functype func[2] = {
+ // array index: UP
+ (internal::packed_rank2_update_selector<Scalar,int,Upper>::run),
+ // array index: LO
+ (internal::packed_rank2_update_selector<Scalar,int,Lower>::run),
+ };
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
@@ -217,19 +197,12 @@
int EIGEN_BLAS_FUNC(her)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *pa, int *lda)
{
typedef void (*functype)(int, Scalar*, int, const Scalar*, const Scalar*, const Scalar&);
- static functype func[2];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (selfadjoint_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run);
- func[LO] = (selfadjoint_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run);
-
- init = true;
- }
+ static const functype func[2] = {
+ // array index: UP
+ (selfadjoint_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run),
+ // array index: LO
+ (selfadjoint_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run),
+ };
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* a = reinterpret_cast<Scalar*>(pa);
@@ -271,19 +244,12 @@
int EIGEN_BLAS_FUNC(her2)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pa, int *lda)
{
typedef void (*functype)(int, Scalar*, int, const Scalar*, const Scalar*, Scalar);
- static functype func[2];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (internal::rank2_update_selector<Scalar,int,Upper>::run);
- func[LO] = (internal::rank2_update_selector<Scalar,int,Lower>::run);
-
- init = true;
- }
+ static const functype func[2] = {
+ // array index: UP
+ (internal::rank2_update_selector<Scalar,int,Upper>::run),
+ // array index: LO
+ (internal::rank2_update_selector<Scalar,int,Lower>::run),
+ };
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
diff --git a/blas/level2_impl.h b/blas/level2_impl.h
index 5f39419..173f40b 100644
--- a/blas/level2_impl.h
+++ b/blas/level2_impl.h
@@ -9,29 +9,39 @@
#include "common.h"
-int EIGEN_BLAS_FUNC(gemv)(char *opa, int *m, int *n, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pb, int *incb, RealScalar *pbeta, RealScalar *pc, int *incc)
+template<typename Index, typename Scalar, int StorageOrder, bool ConjugateLhs, bool ConjugateRhs>
+struct general_matrix_vector_product_wrapper
+{
+ static void run(Index rows, Index cols,const Scalar *lhs, Index lhsStride, const Scalar *rhs, Index rhsIncr, Scalar* res, Index resIncr, Scalar alpha)
+ {
+ typedef internal::const_blas_data_mapper<Scalar,Index,StorageOrder> LhsMapper;
+ typedef internal::const_blas_data_mapper<Scalar,Index,RowMajor> RhsMapper;
+
+ internal::general_matrix_vector_product
+ <Index,Scalar,LhsMapper,StorageOrder,ConjugateLhs,Scalar,RhsMapper,ConjugateRhs>::run(
+ rows, cols, LhsMapper(lhs, lhsStride), RhsMapper(rhs, rhsIncr), res, resIncr, alpha);
+ }
+};
+
+int EIGEN_BLAS_FUNC(gemv)(const char *opa, const int *m, const int *n, const RealScalar *palpha,
+ const RealScalar *pa, const int *lda, const RealScalar *pb, const int *incb, const RealScalar *pbeta, RealScalar *pc, const int *incc)
{
typedef void (*functype)(int, int, const Scalar *, int, const Scalar *, int , Scalar *, int, Scalar);
- static functype func[4];
+ static const functype func[4] = {
+ // array index: NOTR
+ (general_matrix_vector_product_wrapper<int,Scalar,ColMajor,false,false>::run),
+ // array index: TR
+ (general_matrix_vector_product_wrapper<int,Scalar,RowMajor,false,false>::run),
+ // array index: ADJ
+ (general_matrix_vector_product_wrapper<int,Scalar,RowMajor,Conj ,false>::run),
+ 0
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<4; ++k)
- func[k] = 0;
-
- func[NOTR] = (internal::general_matrix_vector_product<int,Scalar,ColMajor,false,Scalar,false>::run);
- func[TR ] = (internal::general_matrix_vector_product<int,Scalar,RowMajor,false,Scalar,false>::run);
- func[ADJ ] = (internal::general_matrix_vector_product<int,Scalar,RowMajor,Conj, Scalar,false>::run);
-
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* b = reinterpret_cast<Scalar*>(pb);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* b = reinterpret_cast<const Scalar*>(pb);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
// check arguments
int info = 0;
@@ -53,13 +63,13 @@
if(code!=NOTR)
std::swap(actual_m,actual_n);
- Scalar* actual_b = get_compact_vector(b,actual_n,*incb);
+ const Scalar* actual_b = get_compact_vector(b,actual_n,*incb);
Scalar* actual_c = get_compact_vector(c,actual_m,*incc);
if(beta!=Scalar(1))
{
- if(beta==Scalar(0)) vector(actual_c, actual_m).setZero();
- else vector(actual_c, actual_m) *= beta;
+ if(beta==Scalar(0)) make_vector(actual_c, actual_m).setZero();
+ else make_vector(actual_c, actual_m) *= beta;
}
if(code>=4 || func[code]==0)
@@ -73,37 +83,41 @@
return 1;
}
-int EIGEN_BLAS_FUNC(trsv)(char *uplo, char *opa, char *diag, int *n, RealScalar *pa, int *lda, RealScalar *pb, int *incb)
+int EIGEN_BLAS_FUNC(trsv)(const char *uplo, const char *opa, const char *diag, const int *n, const RealScalar *pa, const int *lda, RealScalar *pb, const int *incb)
{
typedef void (*functype)(int, const Scalar *, int, Scalar *);
- static functype func[16];
+ static const functype func[16] = {
+ // array index: NOTR | (UP << 2) | (NUNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,ColMajor>::run),
+ // array index: TR | (UP << 2) | (NUNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (NUNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, Conj, RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (NUNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,ColMajor>::run),
+ // array index: TR | (LO << 2) | (NUNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (NUNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, Conj, RowMajor>::run),
+ 0,
+ // array index: NOTR | (UP << 2) | (UNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,ColMajor>::run),
+ // array index: TR | (UP << 2) | (UNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (UNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,Conj, RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (UNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,ColMajor>::run),
+ // array index: TR | (LO << 2) | (UNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (UNIT << 3)
+ (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,Conj, RowMajor>::run),
+ 0
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<16; ++k)
- func[k] = 0;
-
- func[NOTR | (UP << 2) | (NUNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,ColMajor>::run);
- func[TR | (UP << 2) | (NUNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,RowMajor>::run);
- func[ADJ | (UP << 2) | (NUNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, Conj, RowMajor>::run);
-
- func[NOTR | (LO << 2) | (NUNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,ColMajor>::run);
- func[TR | (LO << 2) | (NUNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,RowMajor>::run);
- func[ADJ | (LO << 2) | (NUNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, Conj, RowMajor>::run);
-
- func[NOTR | (UP << 2) | (UNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,ColMajor>::run);
- func[TR | (UP << 2) | (UNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,RowMajor>::run);
- func[ADJ | (UP << 2) | (UNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,Conj, RowMajor>::run);
-
- func[NOTR | (LO << 2) | (UNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,ColMajor>::run);
- func[TR | (LO << 2) | (UNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,RowMajor>::run);
- func[ADJ | (LO << 2) | (UNIT << 3)] = (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,Conj, RowMajor>::run);
-
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
Scalar* b = reinterpret_cast<Scalar*>(pb);
int info = 0;
@@ -128,37 +142,41 @@
-int EIGEN_BLAS_FUNC(trmv)(char *uplo, char *opa, char *diag, int *n, RealScalar *pa, int *lda, RealScalar *pb, int *incb)
+int EIGEN_BLAS_FUNC(trmv)(const char *uplo, const char *opa, const char *diag, const int *n, const RealScalar *pa, const int *lda, RealScalar *pb, const int *incb)
{
typedef void (*functype)(int, int, const Scalar *, int, const Scalar *, int, Scalar *, int, const Scalar&);
- static functype func[16];
+ static const functype func[16] = {
+ // array index: NOTR | (UP << 2) | (NUNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,ColMajor>::run),
+ // array index: TR | (UP << 2) | (NUNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (NUNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,Conj, Scalar,false,RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (NUNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,ColMajor>::run),
+ // array index: TR | (LO << 2) | (NUNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (NUNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,Conj, Scalar,false,RowMajor>::run),
+ 0,
+ // array index: NOTR | (UP << 2) | (UNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run),
+ // array index: TR | (UP << 2) | (UNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (UNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (UNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run),
+ // array index: TR | (LO << 2) | (UNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (UNIT << 3)
+ (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run),
+ 0
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<16; ++k)
- func[k] = 0;
-
- func[NOTR | (UP << 2) | (NUNIT << 3)] = (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,ColMajor>::run);
- func[TR | (UP << 2) | (NUNIT << 3)] = (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,RowMajor>::run);
- func[ADJ | (UP << 2) | (NUNIT << 3)] = (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,Conj, Scalar,false,RowMajor>::run);
-
- func[NOTR | (LO << 2) | (NUNIT << 3)] = (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,ColMajor>::run);
- func[TR | (LO << 2) | (NUNIT << 3)] = (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,RowMajor>::run);
- func[ADJ | (LO << 2) | (NUNIT << 3)] = (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,Conj, Scalar,false,RowMajor>::run);
-
- func[NOTR | (UP << 2) | (UNIT << 3)] = (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run);
- func[TR | (UP << 2) | (UNIT << 3)] = (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run);
- func[ADJ | (UP << 2) | (UNIT << 3)] = (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run);
-
- func[NOTR | (LO << 2) | (UNIT << 3)] = (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run);
- func[TR | (LO << 2) | (UNIT << 3)] = (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run);
- func[ADJ | (LO << 2) | (UNIT << 3)] = (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run);
-
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
Scalar* b = reinterpret_cast<Scalar*>(pb);
int info = 0;
@@ -200,13 +218,13 @@
int EIGEN_BLAS_FUNC(gbmv)(char *trans, int *m, int *n, int *kl, int *ku, RealScalar *palpha, RealScalar *pa, int *lda,
RealScalar *px, int *incx, RealScalar *pbeta, RealScalar *py, int *incy)
{
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* x = reinterpret_cast<Scalar*>(px);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* x = reinterpret_cast<const Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
int coeff_rows = *kl+*ku+1;
-
+
int info = 0;
if(OP(*trans)==INVALID) info = 1;
else if(*m<0) info = 2;
@@ -218,26 +236,26 @@
else if(*incy==0) info = 13;
if(info)
return xerbla_(SCALAR_SUFFIX_UP"GBMV ",&info,6);
-
+
if(*m==0 || *n==0 || (alpha==Scalar(0) && beta==Scalar(1)))
return 0;
-
+
int actual_m = *m;
int actual_n = *n;
if(OP(*trans)!=NOTR)
std::swap(actual_m,actual_n);
-
- Scalar* actual_x = get_compact_vector(x,actual_n,*incx);
+
+ const Scalar* actual_x = get_compact_vector(x,actual_n,*incx);
Scalar* actual_y = get_compact_vector(y,actual_m,*incy);
-
+
if(beta!=Scalar(1))
{
- if(beta==Scalar(0)) vector(actual_y, actual_m).setZero();
- else vector(actual_y, actual_m) *= beta;
+ if(beta==Scalar(0)) make_vector(actual_y, actual_m).setZero();
+ else make_vector(actual_y, actual_m) *= beta;
}
-
- MatrixType mat_coeffs(a,coeff_rows,*n,*lda);
-
+
+ ConstMatrixType mat_coeffs(a,coeff_rows,*n,*lda);
+
int nb = std::min(*n,(*m)+(*ku));
for(int j=0; j<nb; ++j)
{
@@ -246,16 +264,16 @@
int len = end - start + 1;
int offset = (*ku) - j + start;
if(OP(*trans)==NOTR)
- vector(actual_y+start,len) += (alpha*actual_x[j]) * mat_coeffs.col(j).segment(offset,len);
+ make_vector(actual_y+start,len) += (alpha*actual_x[j]) * mat_coeffs.col(j).segment(offset,len);
else if(OP(*trans)==TR)
- actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).transpose() * vector(actual_x+start,len) ).value();
+ actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).transpose() * make_vector(actual_x+start,len) ).value();
else
- actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).adjoint() * vector(actual_x+start,len) ).value();
- }
-
+ actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).adjoint() * make_vector(actual_x+start,len) ).value();
+ }
+
if(actual_x!=x) delete[] actual_x;
if(actual_y!=y) delete[] copy_back(actual_y,y,actual_m,*incy);
-
+
return 0;
}
@@ -272,7 +290,7 @@
Scalar* a = reinterpret_cast<Scalar*>(pa);
Scalar* x = reinterpret_cast<Scalar*>(px);
int coeff_rows = *k + 1;
-
+
int info = 0;
if(UPLO(*uplo)==INVALID) info = 1;
else if(OP(*opa)==INVALID) info = 2;
@@ -283,37 +301,37 @@
else if(*incx==0) info = 9;
if(info)
return xerbla_(SCALAR_SUFFIX_UP"TBMV ",&info,6);
-
+
if(*n==0)
return 0;
-
+
int actual_n = *n;
-
+
Scalar* actual_x = get_compact_vector(x,actual_n,*incx);
-
+
MatrixType mat_coeffs(a,coeff_rows,*n,*lda);
-
+
int ku = UPLO(*uplo)==UPPER ? *k : 0;
int kl = UPLO(*uplo)==LOWER ? *k : 0;
-
+
for(int j=0; j<*n; ++j)
{
int start = std::max(0,j - ku);
int end = std::min((*m)-1,j + kl);
int len = end - start + 1;
int offset = (ku) - j + start;
-
+
if(OP(*trans)==NOTR)
- vector(actual_y+start,len) += (alpha*actual_x[j]) * mat_coeffs.col(j).segment(offset,len);
+ make_vector(actual_y+start,len) += (alpha*actual_x[j]) * mat_coeffs.col(j).segment(offset,len);
else if(OP(*trans)==TR)
- actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).transpose() * vector(actual_x+start,len) ).value();
+ actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).transpose() * make_vector(actual_x+start,len) ).value();
else
- actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).adjoint() * vector(actual_x+start,len) ).value();
- }
-
+ actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).adjoint() * make_vector(actual_x+start,len) ).value();
+ }
+
if(actual_x!=x) delete[] actual_x;
if(actual_y!=y) delete[] copy_back(actual_y,y,actual_m,*incy);
-
+
return 0;
}
#endif
@@ -332,37 +350,41 @@
int EIGEN_BLAS_FUNC(tbsv)(char *uplo, char *op, char *diag, int *n, int *k, RealScalar *pa, int *lda, RealScalar *px, int *incx)
{
typedef void (*functype)(int, int, const Scalar *, int, Scalar *);
- static functype func[16];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<16; ++k)
- func[k] = 0;
-
- func[NOTR | (UP << 2) | (NUNIT << 3)] = (internal::band_solve_triangular_selector<int,Upper|0, Scalar,false,Scalar,ColMajor>::run);
- func[TR | (UP << 2) | (NUNIT << 3)] = (internal::band_solve_triangular_selector<int,Lower|0, Scalar,false,Scalar,RowMajor>::run);
- func[ADJ | (UP << 2) | (NUNIT << 3)] = (internal::band_solve_triangular_selector<int,Lower|0, Scalar,Conj, Scalar,RowMajor>::run);
-
- func[NOTR | (LO << 2) | (NUNIT << 3)] = (internal::band_solve_triangular_selector<int,Lower|0, Scalar,false,Scalar,ColMajor>::run);
- func[TR | (LO << 2) | (NUNIT << 3)] = (internal::band_solve_triangular_selector<int,Upper|0, Scalar,false,Scalar,RowMajor>::run);
- func[ADJ | (LO << 2) | (NUNIT << 3)] = (internal::band_solve_triangular_selector<int,Upper|0, Scalar,Conj, Scalar,RowMajor>::run);
-
- func[NOTR | (UP << 2) | (UNIT << 3)] = (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,false,Scalar,ColMajor>::run);
- func[TR | (UP << 2) | (UNIT << 3)] = (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,false,Scalar,RowMajor>::run);
- func[ADJ | (UP << 2) | (UNIT << 3)] = (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,Conj, Scalar,RowMajor>::run);
-
- func[NOTR | (LO << 2) | (UNIT << 3)] = (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,false,Scalar,ColMajor>::run);
- func[TR | (LO << 2) | (UNIT << 3)] = (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,false,Scalar,RowMajor>::run);
- func[ADJ | (LO << 2) | (UNIT << 3)] = (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,Conj, Scalar,RowMajor>::run);
-
- init = true;
- }
+ static const functype func[16] = {
+ // array index: NOTR | (UP << 2) | (NUNIT << 3)
+ (internal::band_solve_triangular_selector<int,Upper|0, Scalar,false,Scalar,ColMajor>::run),
+ // array index: TR | (UP << 2) | (NUNIT << 3)
+ (internal::band_solve_triangular_selector<int,Lower|0, Scalar,false,Scalar,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (NUNIT << 3)
+ (internal::band_solve_triangular_selector<int,Lower|0, Scalar,Conj, Scalar,RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (NUNIT << 3)
+ (internal::band_solve_triangular_selector<int,Lower|0, Scalar,false,Scalar,ColMajor>::run),
+ // array index: TR | (LO << 2) | (NUNIT << 3)
+ (internal::band_solve_triangular_selector<int,Upper|0, Scalar,false,Scalar,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (NUNIT << 3)
+ (internal::band_solve_triangular_selector<int,Upper|0, Scalar,Conj, Scalar,RowMajor>::run),
+ 0,
+ // array index: NOTR | (UP << 2) | (UNIT << 3)
+ (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,false,Scalar,ColMajor>::run),
+ // array index: TR | (UP << 2) | (UNIT << 3)
+ (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,false,Scalar,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (UNIT << 3)
+ (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,Conj, Scalar,RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (UNIT << 3)
+ (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,false,Scalar,ColMajor>::run),
+ // array index: TR | (LO << 2) | (UNIT << 3)
+ (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,false,Scalar,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (UNIT << 3)
+ (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,Conj, Scalar,RowMajor>::run),
+ 0,
+ };
Scalar* a = reinterpret_cast<Scalar*>(pa);
Scalar* x = reinterpret_cast<Scalar*>(px);
int coeff_rows = *k+1;
-
+
int info = 0;
if(UPLO(*uplo)==INVALID) info = 1;
else if(OP(*op)==INVALID) info = 2;
@@ -373,22 +395,22 @@
else if(*incx==0) info = 9;
if(info)
return xerbla_(SCALAR_SUFFIX_UP"TBSV ",&info,6);
-
+
if(*n==0 || (*k==0 && DIAG(*diag)==UNIT))
return 0;
-
+
int actual_n = *n;
-
+
Scalar* actual_x = get_compact_vector(x,actual_n,*incx);
-
+
int code = OP(*op) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3);
if(code>=16 || func[code]==0)
return 0;
func[code](*n, *k, a, *lda, actual_x);
-
+
if(actual_x!=x) delete[] copy_back(actual_x,x,actual_n,*incx);
-
+
return 0;
}
@@ -402,32 +424,36 @@
int EIGEN_BLAS_FUNC(tpmv)(char *uplo, char *opa, char *diag, int *n, RealScalar *pap, RealScalar *px, int *incx)
{
typedef void (*functype)(int, const Scalar*, const Scalar*, Scalar*, Scalar);
- static functype func[16];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<16; ++k)
- func[k] = 0;
-
- func[NOTR | (UP << 2) | (NUNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,ColMajor>::run);
- func[TR | (UP << 2) | (NUNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,RowMajor>::run);
- func[ADJ | (UP << 2) | (NUNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,Conj, Scalar,false,RowMajor>::run);
-
- func[NOTR | (LO << 2) | (NUNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,ColMajor>::run);
- func[TR | (LO << 2) | (NUNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,RowMajor>::run);
- func[ADJ | (LO << 2) | (NUNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,Conj, Scalar,false,RowMajor>::run);
-
- func[NOTR | (UP << 2) | (UNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run);
- func[TR | (UP << 2) | (UNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run);
- func[ADJ | (UP << 2) | (UNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run);
-
- func[NOTR | (LO << 2) | (UNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run);
- func[TR | (LO << 2) | (UNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run);
- func[ADJ | (LO << 2) | (UNIT << 3)] = (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run);
-
- init = true;
- }
+ static const functype func[16] = {
+ // array index: NOTR | (UP << 2) | (NUNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,ColMajor>::run),
+ // array index: TR | (UP << 2) | (NUNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (NUNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,Conj, Scalar,false,RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (NUNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,ColMajor>::run),
+ // array index: TR | (LO << 2) | (NUNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (NUNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,Conj, Scalar,false,RowMajor>::run),
+ 0,
+ // array index: NOTR | (UP << 2) | (UNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run),
+ // array index: TR | (UP << 2) | (UNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (UNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (UNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run),
+ // array index: TR | (LO << 2) | (UNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (UNIT << 3)
+ (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run),
+ 0
+ };
Scalar* ap = reinterpret_cast<Scalar*>(pap);
Scalar* x = reinterpret_cast<Scalar*>(px);
@@ -473,32 +499,36 @@
int EIGEN_BLAS_FUNC(tpsv)(char *uplo, char *opa, char *diag, int *n, RealScalar *pap, RealScalar *px, int *incx)
{
typedef void (*functype)(int, const Scalar*, Scalar*);
- static functype func[16];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<16; ++k)
- func[k] = 0;
-
- func[NOTR | (UP << 2) | (NUNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,ColMajor>::run);
- func[TR | (UP << 2) | (NUNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,RowMajor>::run);
- func[ADJ | (UP << 2) | (NUNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, Conj, RowMajor>::run);
-
- func[NOTR | (LO << 2) | (NUNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,ColMajor>::run);
- func[TR | (LO << 2) | (NUNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,RowMajor>::run);
- func[ADJ | (LO << 2) | (NUNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, Conj, RowMajor>::run);
-
- func[NOTR | (UP << 2) | (UNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,ColMajor>::run);
- func[TR | (UP << 2) | (UNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,RowMajor>::run);
- func[ADJ | (UP << 2) | (UNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,Conj, RowMajor>::run);
-
- func[NOTR | (LO << 2) | (UNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,ColMajor>::run);
- func[TR | (LO << 2) | (UNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,RowMajor>::run);
- func[ADJ | (LO << 2) | (UNIT << 3)] = (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,Conj, RowMajor>::run);
-
- init = true;
- }
+ static const functype func[16] = {
+ // array index: NOTR | (UP << 2) | (NUNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,ColMajor>::run),
+ // array index: TR | (UP << 2) | (NUNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (NUNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, Conj, RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (NUNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,ColMajor>::run),
+ // array index: TR | (LO << 2) | (NUNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (NUNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, Conj, RowMajor>::run),
+ 0,
+ // array index: NOTR | (UP << 2) | (UNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,ColMajor>::run),
+ // array index: TR | (UP << 2) | (UNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,RowMajor>::run),
+ // array index: ADJ | (UP << 2) | (UNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,Conj, RowMajor>::run),
+ 0,
+ // array index: NOTR | (LO << 2) | (UNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,ColMajor>::run),
+ // array index: TR | (LO << 2) | (UNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,RowMajor>::run),
+ // array index: ADJ | (LO << 2) | (UNIT << 3)
+ (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,Conj, RowMajor>::run),
+ 0
+ };
Scalar* ap = reinterpret_cast<Scalar*>(pap);
Scalar* x = reinterpret_cast<Scalar*>(px);
@@ -521,4 +551,3 @@
return 1;
}
-
diff --git a/blas/level2_real_impl.h b/blas/level2_real_impl.h
index 8d56eaa..7620f0a 100644
--- a/blas/level2_real_impl.h
+++ b/blas/level2_real_impl.h
@@ -10,28 +10,22 @@
#include "common.h"
// y = alpha*A*x + beta*y
-int EIGEN_BLAS_FUNC(symv) (char *uplo, int *n, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *px, int *incx, RealScalar *pbeta, RealScalar *py, int *incy)
+int EIGEN_BLAS_FUNC(symv) (const char *uplo, const int *n, const RealScalar *palpha, const RealScalar *pa, const int *lda,
+ const RealScalar *px, const int *incx, const RealScalar *pbeta, RealScalar *py, const int *incy)
{
- typedef void (*functype)(int, const Scalar*, int, const Scalar*, int, Scalar*, Scalar);
- static functype func[2];
+ typedef void (*functype)(int, const Scalar*, int, const Scalar*, Scalar*, Scalar);
+ static const functype func[2] = {
+ // array index: UP
+ (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Upper,false,false>::run),
+ // array index: LO
+ (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Lower,false,false>::run),
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Upper,false,false>::run);
- func[LO] = (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Lower,false,false>::run);
-
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* x = reinterpret_cast<Scalar*>(px);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* x = reinterpret_cast<const Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
// check arguments
int info = 0;
@@ -46,20 +40,20 @@
if(*n==0)
return 0;
- Scalar* actual_x = get_compact_vector(x,*n,*incx);
+ const Scalar* actual_x = get_compact_vector(x,*n,*incx);
Scalar* actual_y = get_compact_vector(y,*n,*incy);
if(beta!=Scalar(1))
{
- if(beta==Scalar(0)) vector(actual_y, *n).setZero();
- else vector(actual_y, *n) *= beta;
+ if(beta==Scalar(0)) make_vector(actual_y, *n).setZero();
+ else make_vector(actual_y, *n) *= beta;
}
int code = UPLO(*uplo);
if(code>=2 || func[code]==0)
return 0;
- func[code](*n, a, *lda, actual_x, 1, actual_y, alpha);
+ func[code](*n, a, *lda, actual_x, actual_y, alpha);
if(actual_x!=x) delete[] actual_x;
if(actual_y!=y) delete[] copy_back(actual_y,y,*n,*incy);
@@ -68,41 +62,20 @@
}
// C := alpha*x*x' + C
-int EIGEN_BLAS_FUNC(syr)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(syr)(const char *uplo, const int *n, const RealScalar *palpha, const RealScalar *px, const int *incx, RealScalar *pc, const int *ldc)
{
-// typedef void (*functype)(int, const Scalar *, int, Scalar *, int, Scalar);
-// static functype func[2];
-
-// static bool init = false;
-// if(!init)
-// {
-// for(int k=0; k<2; ++k)
-// func[k] = 0;
-//
-// func[UP] = (internal::selfadjoint_product<Scalar,ColMajor,ColMajor,false,UpperTriangular>::run);
-// func[LO] = (internal::selfadjoint_product<Scalar,ColMajor,ColMajor,false,LowerTriangular>::run);
-
-// init = true;
-// }
typedef void (*functype)(int, Scalar*, int, const Scalar*, const Scalar*, const Scalar&);
- static functype func[2];
+ static const functype func[2] = {
+ // array index: UP
+ (selfadjoint_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run),
+ // array index: LO
+ (selfadjoint_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run),
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (selfadjoint_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run);
- func[LO] = (selfadjoint_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run);
-
- init = true;
- }
-
- Scalar* x = reinterpret_cast<Scalar*>(px);
+ const Scalar* x = reinterpret_cast<const Scalar*>(px);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
int info = 0;
if(UPLO(*uplo)==INVALID) info = 1;
@@ -115,7 +88,7 @@
if(*n==0 || alpha==Scalar(0)) return 1;
// if the increment is not 1, let's copy it to a temporary vector to enable vectorization
- Scalar* x_cpy = get_compact_vector(x,*n,*incx);
+ const Scalar* x_cpy = get_compact_vector(x,*n,*incx);
int code = UPLO(*uplo);
if(code>=2 || func[code]==0)
@@ -129,41 +102,20 @@
}
// C := alpha*x*y' + alpha*y*x' + C
-int EIGEN_BLAS_FUNC(syr2)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(syr2)(const char *uplo, const int *n, const RealScalar *palpha, const RealScalar *px, const int *incx, const RealScalar *py, const int *incy, RealScalar *pc, const int *ldc)
{
-// typedef void (*functype)(int, const Scalar *, int, const Scalar *, int, Scalar *, int, Scalar);
-// static functype func[2];
-//
-// static bool init = false;
-// if(!init)
-// {
-// for(int k=0; k<2; ++k)
-// func[k] = 0;
-//
-// func[UP] = (internal::selfadjoint_product<Scalar,ColMajor,ColMajor,false,UpperTriangular>::run);
-// func[LO] = (internal::selfadjoint_product<Scalar,ColMajor,ColMajor,false,LowerTriangular>::run);
-//
-// init = true;
-// }
typedef void (*functype)(int, Scalar*, int, const Scalar*, const Scalar*, Scalar);
- static functype func[2];
+ static const functype func[2] = {
+ // array index: UP
+ (internal::rank2_update_selector<Scalar,int,Upper>::run),
+ // array index: LO
+ (internal::rank2_update_selector<Scalar,int,Lower>::run),
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (internal::rank2_update_selector<Scalar,int,Upper>::run);
- func[LO] = (internal::rank2_update_selector<Scalar,int,Lower>::run);
-
- init = true;
- }
-
- Scalar* x = reinterpret_cast<Scalar*>(px);
- Scalar* y = reinterpret_cast<Scalar*>(py);
+ const Scalar* x = reinterpret_cast<const Scalar*>(px);
+ const Scalar* y = reinterpret_cast<const Scalar*>(py);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
int info = 0;
if(UPLO(*uplo)==INVALID) info = 1;
@@ -177,9 +129,9 @@
if(alpha==Scalar(0))
return 1;
- Scalar* x_cpy = get_compact_vector(x,*n,*incx);
- Scalar* y_cpy = get_compact_vector(y,*n,*incy);
-
+ const Scalar* x_cpy = get_compact_vector(x,*n,*incx);
+ const Scalar* y_cpy = get_compact_vector(y,*n,*incy);
+
int code = UPLO(*uplo);
if(code>=2 || func[code]==0)
return 0;
@@ -234,19 +186,12 @@
int EIGEN_BLAS_FUNC(spr)(char *uplo, int *n, Scalar *palpha, Scalar *px, int *incx, Scalar *pap)
{
typedef void (*functype)(int, Scalar*, const Scalar*, Scalar);
- static functype func[2];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Upper,false,false>::run);
- func[LO] = (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Lower,false,false>::run);
-
- init = true;
- }
+ static const functype func[2] = {
+ // array index: UP
+ (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Upper,false,false>::run),
+ // array index: LO
+ (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Lower,false,false>::run),
+ };
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* ap = reinterpret_cast<Scalar*>(pap);
@@ -285,19 +230,12 @@
int EIGEN_BLAS_FUNC(spr2)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pap)
{
typedef void (*functype)(int, Scalar*, const Scalar*, const Scalar*, Scalar);
- static functype func[2];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<2; ++k)
- func[k] = 0;
-
- func[UP] = (internal::packed_rank2_update_selector<Scalar,int,Upper>::run);
- func[LO] = (internal::packed_rank2_update_selector<Scalar,int,Lower>::run);
-
- init = true;
- }
+ static const functype func[2] = {
+ // array index: UP
+ (internal::packed_rank2_update_selector<Scalar,int,Upper>::run),
+ // array index: LO
+ (internal::packed_rank2_update_selector<Scalar,int,Lower>::run),
+ };
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
@@ -366,5 +304,3 @@
return 1;
}
-
-
diff --git a/blas/level3_impl.h b/blas/level3_impl.h
index 07dbc22..6c802cd 100644
--- a/blas/level3_impl.h
+++ b/blas/level3_impl.h
@@ -6,37 +6,43 @@
// This Source Code Form is subject to the terms of the Mozilla
// Public License v. 2.0. If a copy of the MPL was not distributed
// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
-
+#include <iostream>
#include "common.h"
-int EIGEN_BLAS_FUNC(gemm)(char *opa, char *opb, int *m, int *n, int *k, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, RealScalar *pbeta, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(gemm)(const char *opa, const char *opb, const int *m, const int *n, const int *k, const RealScalar *palpha,
+ const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc)
{
// std::cerr << "in gemm " << *opa << " " << *opb << " " << *m << " " << *n << " " << *k << " " << *lda << " " << *ldb << " " << *ldc << " " << *palpha << " " << *pbeta << "\n";
typedef void (*functype)(DenseIndex, DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, Scalar, internal::level3_blocking<Scalar,Scalar>&, Eigen::internal::GemmParallelInfo<DenseIndex>*);
- static functype func[12];
+ static const functype func[12] = {
+ // array index: NOTR | (NOTR << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,ColMajor,false,ColMajor>::run),
+ // array index: TR | (NOTR << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,false,ColMajor>::run),
+ // array index: ADJ | (NOTR << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor>::run),
+ 0,
+ // array index: NOTR | (TR << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,false,ColMajor>::run),
+ // array index: TR | (TR << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,RowMajor,false,ColMajor>::run),
+ // array index: ADJ | (TR << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,RowMajor,false,ColMajor>::run),
+ 0,
+ // array index: NOTR | (ADJ << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor>::run),
+ // array index: TR | (ADJ << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,RowMajor,Conj, ColMajor>::run),
+ // array index: ADJ | (ADJ << 2)
+ (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,RowMajor,Conj, ColMajor>::run),
+ 0
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<12; ++k)
- func[k] = 0;
- func[NOTR | (NOTR << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,ColMajor,false,ColMajor>::run);
- func[TR | (NOTR << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,false,ColMajor>::run);
- func[ADJ | (NOTR << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor>::run);
- func[NOTR | (TR << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,false,ColMajor>::run);
- func[TR | (TR << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,RowMajor,false,ColMajor>::run);
- func[ADJ | (TR << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,RowMajor,false,ColMajor>::run);
- func[NOTR | (ADJ << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor>::run);
- func[TR | (ADJ << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,RowMajor,Conj, ColMajor>::run);
- func[ADJ | (ADJ << 2)] = (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,RowMajor,Conj, ColMajor>::run);
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* b = reinterpret_cast<Scalar*>(pb);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* b = reinterpret_cast<const Scalar*>(pb);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
int info = 0;
if(OP(*opa)==INVALID) info = 1;
@@ -50,70 +56,92 @@
if(info)
return xerbla_(SCALAR_SUFFIX_UP"GEMM ",&info,6);
+ if (*m == 0 || *n == 0)
+ return 0;
+
if(beta!=Scalar(1))
{
if(beta==Scalar(0)) matrix(c, *m, *n, *ldc).setZero();
else matrix(c, *m, *n, *ldc) *= beta;
}
- internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*m,*n,*k);
+ if(*k == 0)
+ return 0;
+
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*m,*n,*k,1,true);
int code = OP(*opa) | (OP(*opb) << 2);
func[code](*m, *n, *k, a, *lda, b, *ldb, c, *ldc, alpha, blocking, 0);
return 0;
}
-int EIGEN_BLAS_FUNC(trsm)(char *side, char *uplo, char *opa, char *diag, int *m, int *n, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pb, int *ldb)
+int EIGEN_BLAS_FUNC(trsm)(const char *side, const char *uplo, const char *opa, const char *diag, const int *m, const int *n,
+ const RealScalar *palpha, const RealScalar *pa, const int *lda, RealScalar *pb, const int *ldb)
{
// std::cerr << "in trsm " << *side << " " << *uplo << " " << *opa << " " << *diag << " " << *m << "," << *n << " " << *palpha << " " << *lda << " " << *ldb<< "\n";
typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, internal::level3_blocking<Scalar,Scalar>&);
- static functype func[32];
+ static const functype func[32] = {
+ // array index: NOTR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, false,ColMajor,ColMajor>::run),
+ // array index: TR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, false,RowMajor,ColMajor>::run),
+ // array index: ADJ | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, Conj, RowMajor,ColMajor>::run),\
+ 0,
+ // array index: NOTR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, false,ColMajor,ColMajor>::run),
+ // array index: TR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, false,RowMajor,ColMajor>::run),
+ // array index: ADJ | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, Conj, RowMajor,ColMajor>::run),
+ 0,
+ // array index: NOTR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, false,ColMajor,ColMajor>::run),
+ // array index: TR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, false,RowMajor,ColMajor>::run),
+ // array index: ADJ | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, Conj, RowMajor,ColMajor>::run),
+ 0,
+ // array index: NOTR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, false,ColMajor,ColMajor>::run),
+ // array index: TR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, false,RowMajor,ColMajor>::run),
+ // array index: ADJ | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, Conj, RowMajor,ColMajor>::run),
+ 0,
+ // array index: NOTR | (LEFT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,false,ColMajor,ColMajor>::run),
+ // array index: TR | (LEFT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,false,RowMajor,ColMajor>::run),
+ // array index: ADJ | (LEFT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,Conj, RowMajor,ColMajor>::run),
+ 0,
+ // array index: NOTR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,false,ColMajor,ColMajor>::run),
+ // array index: TR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,false,RowMajor,ColMajor>::run),
+ // array index: ADJ | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,Conj, RowMajor,ColMajor>::run),
+ 0,
+ // array index: NOTR | (LEFT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,false,ColMajor,ColMajor>::run),
+ // array index: TR | (LEFT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,false,RowMajor,ColMajor>::run),
+ // array index: ADJ | (LEFT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,Conj, RowMajor,ColMajor>::run),
+ 0,
+ // array index: NOTR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,false,ColMajor,ColMajor>::run),
+ // array index: TR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,false,RowMajor,ColMajor>::run),
+ // array index: ADJ | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,Conj, RowMajor,ColMajor>::run),
+ 0
+ };
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<32; ++k)
- func[k] = 0;
-
- func[NOTR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, false,ColMajor,ColMajor>::run);
- func[TR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, false,RowMajor,ColMajor>::run);
- func[ADJ | (LEFT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, Conj, RowMajor,ColMajor>::run);
-
- func[NOTR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, false,ColMajor,ColMajor>::run);
- func[TR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, false,RowMajor,ColMajor>::run);
- func[ADJ | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, Conj, RowMajor,ColMajor>::run);
-
- func[NOTR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, false,ColMajor,ColMajor>::run);
- func[TR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, false,RowMajor,ColMajor>::run);
- func[ADJ | (LEFT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, Conj, RowMajor,ColMajor>::run);
-
- func[NOTR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, false,ColMajor,ColMajor>::run);
- func[TR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, false,RowMajor,ColMajor>::run);
- func[ADJ | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, Conj, RowMajor,ColMajor>::run);
-
-
- func[NOTR | (LEFT << 2) | (UP << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,false,ColMajor,ColMajor>::run);
- func[TR | (LEFT << 2) | (UP << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,false,RowMajor,ColMajor>::run);
- func[ADJ | (LEFT << 2) | (UP << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,Conj, RowMajor,ColMajor>::run);
-
- func[NOTR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,false,ColMajor,ColMajor>::run);
- func[TR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,false,RowMajor,ColMajor>::run);
- func[ADJ | (RIGHT << 2) | (UP << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,Conj, RowMajor,ColMajor>::run);
-
- func[NOTR | (LEFT << 2) | (LO << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,false,ColMajor,ColMajor>::run);
- func[TR | (LEFT << 2) | (LO << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,false,RowMajor,ColMajor>::run);
- func[ADJ | (LEFT << 2) | (LO << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,Conj, RowMajor,ColMajor>::run);
-
- func[NOTR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,false,ColMajor,ColMajor>::run);
- func[TR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,false,RowMajor,ColMajor>::run);
- func[ADJ | (RIGHT << 2) | (LO << 3) | (UNIT << 4)] = (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,Conj, RowMajor,ColMajor>::run);
-
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
Scalar* b = reinterpret_cast<Scalar*>(pb);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
int info = 0;
if(SIDE(*side)==INVALID) info = 1;
@@ -127,16 +155,19 @@
if(info)
return xerbla_(SCALAR_SUFFIX_UP"TRSM ",&info,6);
+ if(*m==0 || *n==0)
+ return 0;
+
int code = OP(*opa) | (SIDE(*side) << 2) | (UPLO(*uplo) << 3) | (DIAG(*diag) << 4);
-
+
if(SIDE(*side)==LEFT)
{
- internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*m);
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*m,1,false);
func[code](*m, *n, a, *lda, b, *ldb, blocking);
}
else
{
- internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*n);
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*n,1,false);
func[code](*n, *m, a, *lda, b, *ldb, blocking);
}
@@ -149,55 +180,73 @@
// b = alpha*op(a)*b for side = 'L'or'l'
// b = alpha*b*op(a) for side = 'R'or'r'
-int EIGEN_BLAS_FUNC(trmm)(char *side, char *uplo, char *opa, char *diag, int *m, int *n, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pb, int *ldb)
+int EIGEN_BLAS_FUNC(trmm)(const char *side, const char *uplo, const char *opa, const char *diag, const int *m, const int *n,
+ const RealScalar *palpha, const RealScalar *pa, const int *lda, RealScalar *pb, const int *ldb)
{
// std::cerr << "in trmm " << *side << " " << *uplo << " " << *opa << " " << *diag << " " << *m << " " << *n << " " << *lda << " " << *ldb << " " << *palpha << "\n";
typedef void (*functype)(DenseIndex, DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, const Scalar&, internal::level3_blocking<Scalar,Scalar>&);
- static functype func[32];
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<32; ++k)
- func[k] = 0;
+ static const functype func[32] = {
+ // array index: NOTR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, ColMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: TR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, RowMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: ADJ | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, RowMajor,Conj, ColMajor,false,ColMajor>::run),
+ 0,
+ // array index: NOTR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: TR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,RowMajor,false,ColMajor>::run),
+ // array index: ADJ | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,RowMajor,Conj, ColMajor>::run),
+ 0,
+ // array index: NOTR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, ColMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: TR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, RowMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: ADJ | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, RowMajor,Conj, ColMajor,false,ColMajor>::run),
+ 0,
+ // array index: NOTR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: TR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,RowMajor,false,ColMajor>::run),
+ // array index: ADJ | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,RowMajor,Conj, ColMajor>::run),
+ 0,
+ // array index: NOTR | (LEFT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, ColMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: TR | (LEFT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, RowMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: ADJ | (LEFT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, RowMajor,Conj, ColMajor,false,ColMajor>::run),
+ 0,
+ // array index: NOTR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: TR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,RowMajor,false,ColMajor>::run),
+ // array index: ADJ | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,RowMajor,Conj, ColMajor>::run),
+ 0,
+ // array index: NOTR | (LEFT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, ColMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: TR | (LEFT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, RowMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: ADJ | (LEFT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, RowMajor,Conj, ColMajor,false,ColMajor>::run),
+ 0,
+ // array index: NOTR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,ColMajor,false,ColMajor>::run),
+ // array index: TR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,RowMajor,false,ColMajor>::run),
+ // array index: ADJ | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
+ (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,RowMajor,Conj, ColMajor>::run),
+ 0
+ };
- func[NOTR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, ColMajor,false,ColMajor,false,ColMajor>::run);
- func[TR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, RowMajor,false,ColMajor,false,ColMajor>::run);
- func[ADJ | (LEFT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, RowMajor,Conj, ColMajor,false,ColMajor>::run);
-
- func[NOTR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,ColMajor,false,ColMajor>::run);
- func[TR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,RowMajor,false,ColMajor>::run);
- func[ADJ | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,RowMajor,Conj, ColMajor>::run);
-
- func[NOTR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, ColMajor,false,ColMajor,false,ColMajor>::run);
- func[TR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, RowMajor,false,ColMajor,false,ColMajor>::run);
- func[ADJ | (LEFT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, RowMajor,Conj, ColMajor,false,ColMajor>::run);
-
- func[NOTR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,ColMajor,false,ColMajor>::run);
- func[TR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,RowMajor,false,ColMajor>::run);
- func[ADJ | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,RowMajor,Conj, ColMajor>::run);
-
- func[NOTR | (LEFT << 2) | (UP << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, ColMajor,false,ColMajor,false,ColMajor>::run);
- func[TR | (LEFT << 2) | (UP << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, RowMajor,false,ColMajor,false,ColMajor>::run);
- func[ADJ | (LEFT << 2) | (UP << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, RowMajor,Conj, ColMajor,false,ColMajor>::run);
-
- func[NOTR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,ColMajor,false,ColMajor>::run);
- func[TR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,RowMajor,false,ColMajor>::run);
- func[ADJ | (RIGHT << 2) | (UP << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,RowMajor,Conj, ColMajor>::run);
-
- func[NOTR | (LEFT << 2) | (LO << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, ColMajor,false,ColMajor,false,ColMajor>::run);
- func[TR | (LEFT << 2) | (LO << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, RowMajor,false,ColMajor,false,ColMajor>::run);
- func[ADJ | (LEFT << 2) | (LO << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, RowMajor,Conj, ColMajor,false,ColMajor>::run);
-
- func[NOTR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,ColMajor,false,ColMajor>::run);
- func[TR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,RowMajor,false,ColMajor>::run);
- func[ADJ | (RIGHT << 2) | (LO << 3) | (UNIT << 4)] = (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,RowMajor,Conj, ColMajor>::run);
-
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
Scalar* b = reinterpret_cast<Scalar*>(pb);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
int info = 0;
if(SIDE(*side)==INVALID) info = 1;
@@ -222,12 +271,12 @@
if(SIDE(*side)==LEFT)
{
- internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*m);
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*m,1,false);
func[code](*m, *n, *m, a, *lda, tmp.data(), tmp.outerStride(), b, *ldb, alpha, blocking);
}
else
{
- internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*n);
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*n,1,false);
func[code](*m, *n, *n, tmp.data(), tmp.outerStride(), a, *lda, b, *ldb, alpha, blocking);
}
return 1;
@@ -235,14 +284,15 @@
// c = alpha*a*b + beta*c for side = 'L'or'l'
// c = alpha*b*a + beta*c for side = 'R'or'r
-int EIGEN_BLAS_FUNC(symm)(char *side, char *uplo, int *m, int *n, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, RealScalar *pbeta, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(symm)(const char *side, const char *uplo, const int *m, const int *n, const RealScalar *palpha,
+ const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc)
{
// std::cerr << "in symm " << *side << " " << *uplo << " " << *m << "x" << *n << " lda:" << *lda << " ldb:" << *ldb << " ldc:" << *ldc << " alpha:" << *palpha << " beta:" << *pbeta << "\n";
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* b = reinterpret_cast<Scalar*>(pb);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* b = reinterpret_cast<const Scalar*>(pb);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
int info = 0;
if(SIDE(*side)==INVALID) info = 1;
@@ -266,9 +316,9 @@
return 1;
}
+ int size = (SIDE(*side)==LEFT) ? (*m) : (*n);
#if ISCOMPLEX
// FIXME add support for symmetric complex matrix
- int size = (SIDE(*side)==LEFT) ? (*m) : (*n);
Matrix<Scalar,Dynamic,Dynamic,ColMajor> matA(size,size);
if(UPLO(*uplo)==UP)
{
@@ -285,13 +335,15 @@
else if(SIDE(*side)==RIGHT)
matrix(c, *m, *n, *ldc) += alpha * matrix(b, *m, *n, *ldb) * matA;
#else
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*m,*n,size,1,false);
+
if(SIDE(*side)==LEFT)
- if(UPLO(*uplo)==UP) internal::product_selfadjoint_matrix<Scalar, DenseIndex, RowMajor,true,false, ColMajor,false,false, ColMajor>::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha);
- else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,true,false, ColMajor,false,false, ColMajor>::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha);
+ if(UPLO(*uplo)==UP) internal::product_selfadjoint_matrix<Scalar, DenseIndex, RowMajor,true,false, ColMajor,false,false, ColMajor>::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha, blocking);
+ else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,true,false, ColMajor,false,false, ColMajor>::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha, blocking);
else return 0;
else if(SIDE(*side)==RIGHT)
- if(UPLO(*uplo)==UP) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,false,false, RowMajor,true,false, ColMajor>::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha);
- else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,false,false, ColMajor,true,false, ColMajor>::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha);
+ if(UPLO(*uplo)==UP) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,false,false, RowMajor,true,false, ColMajor>::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha, blocking);
+ else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,false,false, ColMajor,true,false, ColMajor>::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha, blocking);
else return 0;
else
return 0;
@@ -302,39 +354,38 @@
// c = alpha*a*a' + beta*c for op = 'N'or'n'
// c = alpha*a'*a + beta*c for op = 'T'or't','C'or'c'
-int EIGEN_BLAS_FUNC(syrk)(char *uplo, char *op, int *n, int *k, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pbeta, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(syrk)(const char *uplo, const char *op, const int *n, const int *k,
+ const RealScalar *palpha, const RealScalar *pa, const int *lda, const RealScalar *pbeta, RealScalar *pc, const int *ldc)
{
// std::cerr << "in syrk " << *uplo << " " << *op << " " << *n << " " << *k << " " << *palpha << " " << *lda << " " << *pbeta << " " << *ldc << "\n";
#if !ISCOMPLEX
- typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, const Scalar&);
- static functype func[8];
-
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<8; ++k)
- func[k] = 0;
-
- func[NOTR | (UP << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,ColMajor,Conj, Upper>::run);
- func[TR | (UP << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,ColMajor,Conj, Upper>::run);
- func[ADJ | (UP << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,ColMajor,false,Upper>::run);
-
- func[NOTR | (LO << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,ColMajor,Conj, Lower>::run);
- func[TR | (LO << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,ColMajor,Conj, Lower>::run);
- func[ADJ | (LO << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,ColMajor,false,Lower>::run);
-
- init = true;
- }
+ typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, const Scalar&, internal::level3_blocking<Scalar,Scalar>&);
+ static const functype func[8] = {
+ // array index: NOTR | (UP << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,ColMajor,Conj, Upper>::run),
+ // array index: TR | (UP << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,ColMajor,Conj, Upper>::run),
+ // array index: ADJ | (UP << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,ColMajor,false,Upper>::run),
+ 0,
+ // array index: NOTR | (LO << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,ColMajor,Conj, Lower>::run),
+ // array index: TR | (LO << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,ColMajor,Conj, Lower>::run),
+ // array index: ADJ | (LO << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,ColMajor,false,Lower>::run),
+ 0
+ };
#endif
- Scalar* a = reinterpret_cast<Scalar*>(pa);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
int info = 0;
if(UPLO(*uplo)==INVALID) info = 1;
- else if(OP(*op)==INVALID) info = 2;
+ else if(OP(*op)==INVALID || (ISCOMPLEX && OP(*op)==ADJ) ) info = 2;
else if(*n<0) info = 3;
else if(*k<0) info = 4;
else if(*lda<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 7;
@@ -352,6 +403,9 @@
else matrix(c, *n, *n, *ldc).triangularView<Lower>() *= beta;
}
+ if(*n==0 || *k==0)
+ return 0;
+
#if ISCOMPLEX
// FIXME add support for symmetric complex matrix
if(UPLO(*uplo)==UP)
@@ -369,8 +423,10 @@
matrix(c, *n, *n, *ldc).triangularView<Lower>() += alpha * matrix(a,*k,*n,*lda).transpose() * matrix(a,*k,*n,*lda);
}
#else
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*n,*n,*k,1,false);
+
int code = OP(*op) | (UPLO(*uplo) << 2);
- func[code](*n, *k, a, *lda, a, *lda, c, *ldc, alpha);
+ func[code](*n, *k, a, *lda, a, *lda, c, *ldc, alpha, blocking);
#endif
return 0;
@@ -378,17 +434,20 @@
// c = alpha*a*b' + alpha*b*a' + beta*c for op = 'N'or'n'
// c = alpha*a'*b + alpha*b'*a + beta*c for op = 'T'or't'
-int EIGEN_BLAS_FUNC(syr2k)(char *uplo, char *op, int *n, int *k, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, RealScalar *pbeta, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(syr2k)(const char *uplo, const char *op, const int *n, const int *k, const RealScalar *palpha,
+ const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc)
{
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* b = reinterpret_cast<Scalar*>(pb);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* b = reinterpret_cast<const Scalar*>(pb);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
+
+// std::cerr << "in syr2k " << *uplo << " " << *op << " " << *n << " " << *k << " " << alpha << " " << *lda << " " << *ldb << " " << beta << " " << *ldc << "\n";
int info = 0;
if(UPLO(*uplo)==INVALID) info = 1;
- else if(OP(*op)==INVALID) info = 2;
+ else if(OP(*op)==INVALID || (ISCOMPLEX && OP(*op)==ADJ) ) info = 2;
else if(*n<0) info = 3;
else if(*k<0) info = 4;
else if(*lda<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 7;
@@ -443,13 +502,14 @@
// c = alpha*a*b + beta*c for side = 'L'or'l'
// c = alpha*b*a + beta*c for side = 'R'or'r
-int EIGEN_BLAS_FUNC(hemm)(char *side, char *uplo, int *m, int *n, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, RealScalar *pbeta, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(hemm)(const char *side, const char *uplo, const int *m, const int *n, const RealScalar *palpha,
+ const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc)
{
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* b = reinterpret_cast<Scalar*>(pb);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* b = reinterpret_cast<const Scalar*>(pb);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
- Scalar beta = *reinterpret_cast<Scalar*>(pbeta);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+ Scalar beta = *reinterpret_cast<const Scalar*>(pbeta);
// std::cerr << "in hemm " << *side << " " << *uplo << " " << *m << " " << *n << " " << alpha << " " << *lda << " " << beta << " " << *ldc << "\n";
@@ -472,20 +532,23 @@
return 1;
}
+ int size = (SIDE(*side)==LEFT) ? (*m) : (*n);
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*m,*n,size,1,false);
+
if(SIDE(*side)==LEFT)
{
if(UPLO(*uplo)==UP) internal::product_selfadjoint_matrix<Scalar,DenseIndex,RowMajor,true,Conj, ColMajor,false,false, ColMajor>
- ::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha);
+ ::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha, blocking);
else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar,DenseIndex,ColMajor,true,false, ColMajor,false,false, ColMajor>
- ::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha);
+ ::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha, blocking);
else return 0;
}
else if(SIDE(*side)==RIGHT)
{
if(UPLO(*uplo)==UP) matrix(c,*m,*n,*ldc) += alpha * matrix(b,*m,*n,*ldb) * matrix(a,*n,*n,*lda).selfadjointView<Upper>();/*internal::product_selfadjoint_matrix<Scalar,DenseIndex,ColMajor,false,false, RowMajor,true,Conj, ColMajor>
- ::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha);*/
+ ::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha, blocking);*/
else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar,DenseIndex,ColMajor,false,false, ColMajor,true,false, ColMajor>
- ::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha);
+ ::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha, blocking);
else return 0;
}
else
@@ -498,27 +561,28 @@
// c = alpha*a*conj(a') + beta*c for op = 'N'or'n'
// c = alpha*conj(a')*a + beta*c for op = 'C'or'c'
-int EIGEN_BLAS_FUNC(herk)(char *uplo, char *op, int *n, int *k, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pbeta, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(herk)(const char *uplo, const char *op, const int *n, const int *k,
+ const RealScalar *palpha, const RealScalar *pa, const int *lda, const RealScalar *pbeta, RealScalar *pc, const int *ldc)
{
- typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, const Scalar&);
- static functype func[8];
+// std::cerr << "in herk " << *uplo << " " << *op << " " << *n << " " << *k << " " << *palpha << " " << *lda << " " << *pbeta << " " << *ldc << "\n";
- static bool init = false;
- if(!init)
- {
- for(int k=0; k<8; ++k)
- func[k] = 0;
+ typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, const Scalar&, internal::level3_blocking<Scalar,Scalar>&);
+ static const functype func[8] = {
+ // array index: NOTR | (UP << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor,Upper>::run),
+ 0,
+ // array index: ADJ | (UP << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,Upper>::run),
+ 0,
+ // array index: NOTR | (LO << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor,Lower>::run),
+ 0,
+ // array index: ADJ | (LO << 2)
+ (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,Lower>::run),
+ 0
+ };
- func[NOTR | (UP << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor,Upper>::run);
- func[ADJ | (UP << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,Upper>::run);
-
- func[NOTR | (LO << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor,Lower>::run);
- func[ADJ | (LO << 2)] = (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,Lower>::run);
-
- init = true;
- }
-
- Scalar* a = reinterpret_cast<Scalar*>(pa);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
Scalar* c = reinterpret_cast<Scalar*>(pc);
RealScalar alpha = *palpha;
RealScalar beta = *pbeta;
@@ -545,7 +609,7 @@
else
if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Lower>().setZero();
else matrix(c, *n, *n, *ldc).triangularView<StrictlyLower>() *= beta;
-
+
if(beta!=Scalar(0))
{
matrix(c, *n, *n, *ldc).diagonal().real() *= beta;
@@ -555,7 +619,8 @@
if(*k>0 && alpha!=RealScalar(0))
{
- func[code](*n, *k, a, *lda, a, *lda, c, *ldc, alpha);
+ internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*n,*n,*k,1,false);
+ func[code](*n, *k, a, *lda, a, *lda, c, *ldc, alpha, blocking);
matrix(c, *n, *n, *ldc).diagonal().imag().setZero();
}
return 0;
@@ -563,21 +628,24 @@
// c = alpha*a*conj(b') + conj(alpha)*b*conj(a') + beta*c, for op = 'N'or'n'
// c = alpha*conj(a')*b + conj(alpha)*conj(b')*a + beta*c, for op = 'C'or'c'
-int EIGEN_BLAS_FUNC(her2k)(char *uplo, char *op, int *n, int *k, RealScalar *palpha, RealScalar *pa, int *lda, RealScalar *pb, int *ldb, RealScalar *pbeta, RealScalar *pc, int *ldc)
+int EIGEN_BLAS_FUNC(her2k)(const char *uplo, const char *op, const int *n, const int *k,
+ const RealScalar *palpha, const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc)
{
- Scalar* a = reinterpret_cast<Scalar*>(pa);
- Scalar* b = reinterpret_cast<Scalar*>(pb);
+ const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+ const Scalar* b = reinterpret_cast<const Scalar*>(pb);
Scalar* c = reinterpret_cast<Scalar*>(pc);
- Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+ Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
RealScalar beta = *pbeta;
+// std::cerr << "in her2k " << *uplo << " " << *op << " " << *n << " " << *k << " " << alpha << " " << *lda << " " << *ldb << " " << beta << " " << *ldc << "\n";
+
int info = 0;
if(UPLO(*uplo)==INVALID) info = 1;
else if((OP(*op)==INVALID) || (OP(*op)==TR)) info = 2;
else if(*n<0) info = 3;
else if(*k<0) info = 4;
else if(*lda<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 7;
- else if(*lda<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 9;
+ else if(*ldb<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 9;
else if(*ldc<std::max(1,*n)) info = 12;
if(info)
return xerbla_(SCALAR_SUFFIX_UP"HER2K",&info,6);
diff --git a/blas/lsame.f b/blas/lsame.f
deleted file mode 100644
index f536902..0000000
--- a/blas/lsame.f
+++ /dev/null
@@ -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
diff --git a/blas/single.cpp b/blas/single.cpp
index 836e3ee..20ea57d 100644
--- a/blas/single.cpp
+++ b/blas/single.cpp
@@ -19,4 +19,4 @@
#include "level3_impl.h"
float BLASFUNC(sdsdot)(int* n, float* alpha, float* x, int* incx, float* y, int* incy)
-{ return *alpha + BLASFUNC(dsdot)(n, x, incx, y, incy); }
+{ return double(*alpha) + BLASFUNC(dsdot)(n, x, incx, y, incy); }
diff --git a/blas/srotm.f b/blas/srotm.f
deleted file mode 100644
index fc5a593..0000000
--- a/blas/srotm.f
+++ /dev/null
@@ -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
diff --git a/blas/srotmg.f b/blas/srotmg.f
deleted file mode 100644
index 7b3bd42..0000000
--- a/blas/srotmg.f
+++ /dev/null
@@ -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
diff --git a/blas/ssbmv.f b/blas/ssbmv.f
deleted file mode 100644
index 16893a2..0000000
--- a/blas/ssbmv.f
+++ /dev/null
@@ -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
diff --git a/blas/sspmv.f b/blas/sspmv.f
deleted file mode 100644
index 0b84498..0000000
--- a/blas/sspmv.f
+++ /dev/null
@@ -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
diff --git a/blas/stbmv.f b/blas/stbmv.f
deleted file mode 100644
index c0b8f11..0000000
--- a/blas/stbmv.f
+++ /dev/null
@@ -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
diff --git a/blas/testing/cblat1.f b/blas/testing/cblat1.f
index a4c996f..8ca67fb 100644
--- a/blas/testing/cblat1.f
+++ b/blas/testing/cblat1.f
@@ -1,7 +1,49 @@
+*> \brief \b CBLAT1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM CBLAT1
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the COMPLEX Level 1 BLAS.
+*> Based upon the original BLAS test routine together with:
+*>
+*> F06GAF Example Program Text
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup complex_blas_testing
+*
+* =====================================================================
PROGRAM CBLAT1
-* Test program for the COMPLEX Level 1 BLAS.
-* Based upon the original BLAS test routine together with:
-* F06GAF Example Program Text
+*
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* =====================================================================
+*
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
@@ -114,8 +156,8 @@
+ (5.0E0,6.0E0), (5.0E0,6.0E0), (0.1E0,0.1E0),
+ (-0.6E0,0.1E0), (0.1E0,-0.3E0), (7.0E0,8.0E0),
+ (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
- + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.1E0,0.4E0),
- + (0.4E0,0.1E0), (0.1E0,0.2E0), (2.0E0,3.0E0),
+ + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.5E0,0.0E0),
+ + (0.0E0,0.5E0), (0.0E0,0.2E0), (2.0E0,3.0E0),
+ (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/
DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0),
+ (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
@@ -129,10 +171,10 @@
+ (3.0E0,6.0E0), (-0.6E0,0.1E0), (4.0E0,7.0E0),
+ (0.1E0,-0.3E0), (7.0E0,2.0E0), (7.0E0,2.0E0),
+ (7.0E0,2.0E0), (0.3E0,0.1E0), (5.0E0,8.0E0),
- + (0.1E0,0.4E0), (6.0E0,9.0E0), (0.4E0,0.1E0),
- + (8.0E0,3.0E0), (0.1E0,0.2E0), (9.0E0,4.0E0)/
- DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.7E0/
- DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.7E0/
+ + (0.5E0,0.0E0), (6.0E0,9.0E0), (0.0E0,0.5E0),
+ + (8.0E0,3.0E0), (0.0E0,0.2E0), (9.0E0,4.0E0)/
+ DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.8E0/
+ DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.6E0/
DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0),
+ (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
+ (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
@@ -145,8 +187,8 @@
+ (0.11E0,-0.03E0), (-0.17E0,0.46E0),
+ (-0.17E0,-0.19E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
+ (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
- + (0.19E0,-0.17E0), (0.32E0,0.09E0),
- + (0.23E0,-0.24E0), (0.18E0,0.01E0),
+ + (0.19E0,-0.17E0), (0.20E0,-0.35E0),
+ + (0.35E0,0.20E0), (0.14E0,0.08E0),
+ (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0),
+ (2.0E0,3.0E0)/
DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0),
@@ -162,9 +204,9 @@
+ (-0.17E0,0.46E0), (4.0E0,7.0E0),
+ (-0.17E0,-0.19E0), (7.0E0,2.0E0), (7.0E0,2.0E0),
+ (7.0E0,2.0E0), (0.19E0,-0.17E0), (5.0E0,8.0E0),
- + (0.32E0,0.09E0), (6.0E0,9.0E0),
- + (0.23E0,-0.24E0), (8.0E0,3.0E0),
- + (0.18E0,0.01E0), (9.0E0,4.0E0)/
+ + (0.20E0,-0.35E0), (6.0E0,9.0E0),
+ + (0.35E0,0.20E0), (8.0E0,3.0E0),
+ + (0.14E0,0.08E0), (9.0E0,4.0E0)/
DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0),
+ (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
+ (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
@@ -177,8 +219,8 @@
+ (0.03E0,0.03E0), (-0.18E0,0.03E0),
+ (0.03E0,-0.09E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
+ (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
- + (0.09E0,0.03E0), (0.03E0,0.12E0),
- + (0.12E0,0.03E0), (0.03E0,0.06E0), (2.0E0,3.0E0),
+ + (0.09E0,0.03E0), (0.15E0,0.00E0),
+ + (0.00E0,0.15E0), (0.00E0,0.06E0), (2.0E0,3.0E0),
+ (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/
DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0),
+ (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
@@ -193,8 +235,8 @@
+ (-0.18E0,0.03E0), (4.0E0,7.0E0),
+ (0.03E0,-0.09E0), (7.0E0,2.0E0), (7.0E0,2.0E0),
+ (7.0E0,2.0E0), (0.09E0,0.03E0), (5.0E0,8.0E0),
- + (0.03E0,0.12E0), (6.0E0,9.0E0), (0.12E0,0.03E0),
- + (8.0E0,3.0E0), (0.03E0,0.06E0), (9.0E0,4.0E0)/
+ + (0.15E0,0.00E0), (6.0E0,9.0E0), (0.00E0,0.15E0),
+ + (8.0E0,3.0E0), (0.00E0,0.06E0), (9.0E0,4.0E0)/
DATA ITRUE3/0, 1, 2, 2, 2/
* .. Executable Statements ..
DO 60 INCX = 1, 2
@@ -529,7 +571,8 @@
*
* .. Parameters ..
INTEGER NOUT
- PARAMETER (NOUT=6)
+ REAL ZERO
+ PARAMETER (NOUT=6, ZERO=0.0E0)
* .. Scalar Arguments ..
REAL SFAC
INTEGER LEN
@@ -552,7 +595,7 @@
*
DO 40 I = 1, LEN
SD = SCOMP(I) - STRUE(I)
- IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0E0)
+ IF (ABS(SFAC*SD) .LE. ABS(SSIZE(I))*EPSILON(ZERO))
+ GO TO 40
*
* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
diff --git a/blas/testing/cblat2.f b/blas/testing/cblat2.f
index 20f1881..5833ea8 100644
--- a/blas/testing/cblat2.f
+++ b/blas/testing/cblat2.f
@@ -1,68 +1,114 @@
+*> \brief \b CBLAT2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM CBLAT2
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the COMPLEX Level 2 Blas.
+*>
+*> The program must be driven by a short data file. The first 18 records
+*> of the file are read using list-directed input, the last 17 records
+*> are read using the format ( A6, L2 ). An annotated example of a data
+*> file can be obtained by deleting the first 3 characters from the
+*> following 35 lines:
+*> 'cblat2.out' NAME OF SUMMARY OUTPUT FILE
+*> 6 UNIT NUMBER OF SUMMARY FILE
+*> 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+*> F LOGICAL FLAG, T TO STOP ON FAILURES.
+*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
+*> 16.0 THRESHOLD VALUE OF TEST RATIO
+*> 6 NUMBER OF VALUES OF N
+*> 0 1 2 3 5 9 VALUES OF N
+*> 4 NUMBER OF VALUES OF K
+*> 0 1 2 4 VALUES OF K
+*> 4 NUMBER OF VALUES OF INCX AND INCY
+*> 1 2 -1 -2 VALUES OF INCX AND INCY
+*> 3 NUMBER OF VALUES OF ALPHA
+*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
+*> 3 NUMBER OF VALUES OF BETA
+*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
+*> CGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHEMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHPMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CTRMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CTBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CTPMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CTRSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CTBSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CTPSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> CGERC T PUT F FOR NO TEST. SAME COLUMNS.
+*> CGERU T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHER T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHPR T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHER2 T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHPR2 T PUT F FOR NO TEST. SAME COLUMNS.
+*>
+*> Further Details
+*> ===============
+*>
+*> See:
+*>
+*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
+*> An extended set of Fortran Basic Linear Algebra Subprograms.
+*>
+*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
+*> and Computer Science Division, Argonne National Laboratory,
+*> 9700 South Cass Avenue, Argonne, Illinois 60439, US.
+*>
+*> Or
+*>
+*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
+*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
+*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
+*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
+*>
+*>
+*> -- Written on 10-August-1987.
+*> Richard Hanson, Sandia National Labs.
+*> Jeremy Du Croz, NAG Central Office.
+*>
+*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+*> can be run multiple times without deleting generated
+*> output files (susan)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup complex_blas_testing
+*
+* =====================================================================
PROGRAM CBLAT2
*
-* Test program for the COMPLEX Level 2 Blas.
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
*
-* The program must be driven by a short data file. The first 18 records
-* of the file are read using list-directed input, the last 17 records
-* are read using the format ( A6, L2 ). An annotated example of a data
-* file can be obtained by deleting the first 3 characters from the
-* following 35 lines:
-* 'CBLAT2.SUMM' NAME OF SUMMARY OUTPUT FILE
-* 6 UNIT NUMBER OF SUMMARY FILE
-* 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
-* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-* F LOGICAL FLAG, T TO STOP ON FAILURES.
-* T LOGICAL FLAG, T TO TEST ERROR EXITS.
-* 16.0 THRESHOLD VALUE OF TEST RATIO
-* 6 NUMBER OF VALUES OF N
-* 0 1 2 3 5 9 VALUES OF N
-* 4 NUMBER OF VALUES OF K
-* 0 1 2 4 VALUES OF K
-* 4 NUMBER OF VALUES OF INCX AND INCY
-* 1 2 -1 -2 VALUES OF INCX AND INCY
-* 3 NUMBER OF VALUES OF ALPHA
-* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
-* 3 NUMBER OF VALUES OF BETA
-* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
-* CGEMV T PUT F FOR NO TEST. SAME COLUMNS.
-* CGBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* CHEMV T PUT F FOR NO TEST. SAME COLUMNS.
-* CHBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* CHPMV T PUT F FOR NO TEST. SAME COLUMNS.
-* CTRMV T PUT F FOR NO TEST. SAME COLUMNS.
-* CTBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* CTPMV T PUT F FOR NO TEST. SAME COLUMNS.
-* CTRSV T PUT F FOR NO TEST. SAME COLUMNS.
-* CTBSV T PUT F FOR NO TEST. SAME COLUMNS.
-* CTPSV T PUT F FOR NO TEST. SAME COLUMNS.
-* CGERC T PUT F FOR NO TEST. SAME COLUMNS.
-* CGERU T PUT F FOR NO TEST. SAME COLUMNS.
-* CHER T PUT F FOR NO TEST. SAME COLUMNS.
-* CHPR T PUT F FOR NO TEST. SAME COLUMNS.
-* CHER2 T PUT F FOR NO TEST. SAME COLUMNS.
-* CHPR2 T PUT F FOR NO TEST. SAME COLUMNS.
-*
-* See:
-*
-* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
-* An extended set of Fortran Basic Linear Algebra Subprograms.
-*
-* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
-* and Computer Science Division, Argonne National Laboratory,
-* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
-*
-* Or
-*
-* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
-* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
-* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
-* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
-*
-*
-* -- Written on 10-August-1987.
-* Richard Hanson, Sandia National Labs.
-* Jeremy Du Croz, NAG Central Office.
+* =====================================================================
*
* .. Parameters ..
INTEGER NIN
@@ -71,8 +117,8 @@
PARAMETER ( NSUBS = 17 )
COMPLEX ZERO, ONE
PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
- REAL RZERO, RHALF, RONE
- PARAMETER ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 )
+ REAL RZERO
+ PARAMETER ( RZERO = 0.0 )
INTEGER NMAX, INCMAX
PARAMETER ( NMAX = 65, INCMAX = 2 )
INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
@@ -126,7 +172,7 @@
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
- OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
+ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
@@ -135,7 +181,7 @@
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
- OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
+ OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
@@ -240,14 +286,7 @@
*
* Compute EPS (the machine precision).
*
- EPS = RONE
- 90 CONTINUE
- IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO )
- $ GO TO 100
- EPS = RHALF*EPS
- GO TO 90
- 100 CONTINUE
- EPS = EPS + EPS
+ EPS = EPSILON(RZERO)
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of CMVCH using exact data.
@@ -3079,7 +3118,6 @@
50 CONTINUE
END IF
*
- 60 CONTINUE
LCERES = .TRUE.
GO TO 80
70 CONTINUE
diff --git a/blas/testing/cblat3.f b/blas/testing/cblat3.f
index b26be91..09f2cb9 100644
--- a/blas/testing/cblat3.f
+++ b/blas/testing/cblat3.f
@@ -1,50 +1,96 @@
+*> \brief \b CBLAT3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM CBLAT3
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the COMPLEX Level 3 Blas.
+*>
+*> The program must be driven by a short data file. The first 14 records
+*> of the file are read using list-directed input, the last 9 records
+*> are read using the format ( A6, L2 ). An annotated example of a data
+*> file can be obtained by deleting the first 3 characters from the
+*> following 23 lines:
+*> 'cblat3.out' NAME OF SUMMARY OUTPUT FILE
+*> 6 UNIT NUMBER OF SUMMARY FILE
+*> 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+*> F LOGICAL FLAG, T TO STOP ON FAILURES.
+*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
+*> 16.0 THRESHOLD VALUE OF TEST RATIO
+*> 6 NUMBER OF VALUES OF N
+*> 0 1 2 3 5 9 VALUES OF N
+*> 3 NUMBER OF VALUES OF ALPHA
+*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
+*> 3 NUMBER OF VALUES OF BETA
+*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
+*> CGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHEMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> CSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> CTRMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> CTRSM T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHERK T PUT F FOR NO TEST. SAME COLUMNS.
+*> CSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+*> CHER2K T PUT F FOR NO TEST. SAME COLUMNS.
+*> CSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
+*>
+*> Further Details
+*> ===============
+*>
+*> See:
+*>
+*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
+*> A Set of Level 3 Basic Linear Algebra Subprograms.
+*>
+*> Technical Memorandum No.88 (Revision 1), Mathematics and
+*> Computer Science Division, Argonne National Laboratory, 9700
+*> South Cass Avenue, Argonne, Illinois 60439, US.
+*>
+*> -- Written on 8-February-1989.
+*> Jack Dongarra, Argonne National Laboratory.
+*> Iain Duff, AERE Harwell.
+*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*> Sven Hammarling, Numerical Algorithms Group Ltd.
+*>
+*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+*> can be run multiple times without deleting generated
+*> output files (susan)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup complex_blas_testing
+*
+* =====================================================================
PROGRAM CBLAT3
*
-* Test program for the COMPLEX Level 3 Blas.
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
*
-* The program must be driven by a short data file. The first 14 records
-* of the file are read using list-directed input, the last 9 records
-* are read using the format ( A6, L2 ). An annotated example of a data
-* file can be obtained by deleting the first 3 characters from the
-* following 23 lines:
-* 'CBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE
-* 6 UNIT NUMBER OF SUMMARY FILE
-* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
-* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-* F LOGICAL FLAG, T TO STOP ON FAILURES.
-* T LOGICAL FLAG, T TO TEST ERROR EXITS.
-* 16.0 THRESHOLD VALUE OF TEST RATIO
-* 6 NUMBER OF VALUES OF N
-* 0 1 2 3 5 9 VALUES OF N
-* 3 NUMBER OF VALUES OF ALPHA
-* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
-* 3 NUMBER OF VALUES OF BETA
-* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
-* CGEMM T PUT F FOR NO TEST. SAME COLUMNS.
-* CHEMM T PUT F FOR NO TEST. SAME COLUMNS.
-* CSYMM T PUT F FOR NO TEST. SAME COLUMNS.
-* CTRMM T PUT F FOR NO TEST. SAME COLUMNS.
-* CTRSM T PUT F FOR NO TEST. SAME COLUMNS.
-* CHERK T PUT F FOR NO TEST. SAME COLUMNS.
-* CSYRK T PUT F FOR NO TEST. SAME COLUMNS.
-* CHER2K T PUT F FOR NO TEST. SAME COLUMNS.
-* CSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
-*
-* See:
-*
-* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
-* A Set of Level 3 Basic Linear Algebra Subprograms.
-*
-* Technical Memorandum No.88 (Revision 1), Mathematics and
-* Computer Science Division, Argonne National Laboratory, 9700
-* South Cass Avenue, Argonne, Illinois 60439, US.
-*
-* -- Written on 8-February-1989.
-* Jack Dongarra, Argonne National Laboratory.
-* Iain Duff, AERE Harwell.
-* Jeremy Du Croz, Numerical Algorithms Group Ltd.
-* Sven Hammarling, Numerical Algorithms Group Ltd.
+* =====================================================================
*
* .. Parameters ..
INTEGER NIN
@@ -53,8 +99,8 @@
PARAMETER ( NSUBS = 9 )
COMPLEX ZERO, ONE
PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
- REAL RZERO, RHALF, RONE
- PARAMETER ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 )
+ REAL RZERO
+ PARAMETER ( RZERO = 0.0 )
INTEGER NMAX
PARAMETER ( NMAX = 65 )
INTEGER NIDMAX, NALMAX, NBEMAX
@@ -103,7 +149,7 @@
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
- OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
+ OPEN( NOUT, FILE = SUMMRY )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
@@ -112,7 +158,7 @@
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
- OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
+ OPEN( NTRA, FILE = SNAPS )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
@@ -189,14 +235,7 @@
*
* Compute EPS (the machine precision).
*
- EPS = RONE
- 70 CONTINUE
- IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO )
- $ GO TO 80
- EPS = RHALF*EPS
- GO TO 70
- 80 CONTINUE
- EPS = EPS + EPS
+ EPS = EPSILON(RZERO)
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of CMMCH using exact data.
@@ -1946,7 +1985,7 @@
*
* Tests the error exits from the Level 3 Blas.
* Requires a special version of the error-handling routine XERBLA.
-* ALPHA, RALPHA, BETA, RBETA, A, B and C should not need to be defined.
+* A, B and C should not need to be defined.
*
* Auxiliary routine for test program for Level 3 Blas.
*
@@ -1956,12 +1995,19 @@
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
+* 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca)
+* 3-19-92: Fix argument 12 in calls to CSYMM and CHEMM
+* with INFOT = 9 (eca)
+*
* .. Scalar Arguments ..
INTEGER ISNUM, NOUT
CHARACTER*6 SRNAMT
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
+* .. Parameters ..
+ REAL ONE, TWO
+ PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 )
* .. Local Scalars ..
COMPLEX ALPHA, BETA
REAL RALPHA, RBETA
@@ -1979,6 +2025,14 @@
* LERR is set to .TRUE. by the special version of XERBLA each time
* it is called, and is then tested and re-set by CHKXER.
LERR = .FALSE.
+*
+* Initialize ALPHA, BETA, RALPHA, and RBETA.
+*
+ ALPHA = CMPLX( ONE, -ONE )
+ BETA = CMPLX( TWO, -TWO )
+ RALPHA = ONE
+ RBETA = TWO
+*
GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
$ 90 )ISNUM
10 INFOT = 1
@@ -2205,16 +2259,16 @@
CALL CHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
@@ -2272,16 +2326,16 @@
CALL CSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
@@ -3268,7 +3322,6 @@
50 CONTINUE
END IF
*
- 60 CONTINUE
LCERES = .TRUE.
GO TO 80
70 CONTINUE
diff --git a/blas/testing/dblat2.f b/blas/testing/dblat2.f
index 4002d43..0fa80af 100644
--- a/blas/testing/dblat2.f
+++ b/blas/testing/dblat2.f
@@ -1,75 +1,121 @@
+*> \brief \b DBLAT2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM DBLAT2
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the DOUBLE PRECISION Level 2 Blas.
+*>
+*> The program must be driven by a short data file. The first 18 records
+*> of the file are read using list-directed input, the last 16 records
+*> are read using the format ( A6, L2 ). An annotated example of a data
+*> file can be obtained by deleting the first 3 characters from the
+*> following 34 lines:
+*> 'dblat2.out' NAME OF SUMMARY OUTPUT FILE
+*> 6 UNIT NUMBER OF SUMMARY FILE
+*> 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+*> F LOGICAL FLAG, T TO STOP ON FAILURES.
+*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
+*> 16.0 THRESHOLD VALUE OF TEST RATIO
+*> 6 NUMBER OF VALUES OF N
+*> 0 1 2 3 5 9 VALUES OF N
+*> 4 NUMBER OF VALUES OF K
+*> 0 1 2 4 VALUES OF K
+*> 4 NUMBER OF VALUES OF INCX AND INCY
+*> 1 2 -1 -2 VALUES OF INCX AND INCY
+*> 3 NUMBER OF VALUES OF ALPHA
+*> 0.0 1.0 0.7 VALUES OF ALPHA
+*> 3 NUMBER OF VALUES OF BETA
+*> 0.0 1.0 0.9 VALUES OF BETAC
+*> DGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSYMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSPMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DTRMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DTBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DTPMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DTRSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DTBSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DTPSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> DGER T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSYR T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSPR T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
+*>
+*> Further Details
+*> ===============
+*>
+*> See:
+*>
+*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
+*> An extended set of Fortran Basic Linear Algebra Subprograms.
+*>
+*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
+*> and Computer Science Division, Argonne National Laboratory,
+*> 9700 South Cass Avenue, Argonne, Illinois 60439, US.
+*>
+*> Or
+*>
+*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
+*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
+*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
+*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
+*>
+*>
+*> -- Written on 10-August-1987.
+*> Richard Hanson, Sandia National Labs.
+*> Jeremy Du Croz, NAG Central Office.
+*>
+*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+*> can be run multiple times without deleting generated
+*> output files (susan)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup double_blas_testing
+*
+* =====================================================================
PROGRAM DBLAT2
*
-* Test program for the DOUBLE PRECISION Level 2 Blas.
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
*
-* The program must be driven by a short data file. The first 18 records
-* of the file are read using list-directed input, the last 16 records
-* are read using the format ( A6, L2 ). An annotated example of a data
-* file can be obtained by deleting the first 3 characters from the
-* following 34 lines:
-* 'DBLAT2.SUMM' NAME OF SUMMARY OUTPUT FILE
-* 6 UNIT NUMBER OF SUMMARY FILE
-* 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
-* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-* F LOGICAL FLAG, T TO STOP ON FAILURES.
-* T LOGICAL FLAG, T TO TEST ERROR EXITS.
-* 16.0 THRESHOLD VALUE OF TEST RATIO
-* 6 NUMBER OF VALUES OF N
-* 0 1 2 3 5 9 VALUES OF N
-* 4 NUMBER OF VALUES OF K
-* 0 1 2 4 VALUES OF K
-* 4 NUMBER OF VALUES OF INCX AND INCY
-* 1 2 -1 -2 VALUES OF INCX AND INCY
-* 3 NUMBER OF VALUES OF ALPHA
-* 0.0 1.0 0.7 VALUES OF ALPHA
-* 3 NUMBER OF VALUES OF BETA
-* 0.0 1.0 0.9 VALUES OF BETA
-* DGEMV T PUT F FOR NO TEST. SAME COLUMNS.
-* DGBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* DSYMV T PUT F FOR NO TEST. SAME COLUMNS.
-* DSBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* DSPMV T PUT F FOR NO TEST. SAME COLUMNS.
-* DTRMV T PUT F FOR NO TEST. SAME COLUMNS.
-* DTBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* DTPMV T PUT F FOR NO TEST. SAME COLUMNS.
-* DTRSV T PUT F FOR NO TEST. SAME COLUMNS.
-* DTBSV T PUT F FOR NO TEST. SAME COLUMNS.
-* DTPSV T PUT F FOR NO TEST. SAME COLUMNS.
-* DGER T PUT F FOR NO TEST. SAME COLUMNS.
-* DSYR T PUT F FOR NO TEST. SAME COLUMNS.
-* DSPR T PUT F FOR NO TEST. SAME COLUMNS.
-* DSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
-* DSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
-*
-* See:
-*
-* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
-* An extended set of Fortran Basic Linear Algebra Subprograms.
-*
-* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
-* and Computer Science Division, Argonne National Laboratory,
-* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
-*
-* Or
-*
-* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
-* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
-* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
-* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
-*
-*
-* -- Written on 10-August-1987.
-* Richard Hanson, Sandia National Labs.
-* Jeremy Du Croz, NAG Central Office.
+* =====================================================================
*
* .. Parameters ..
INTEGER NIN
PARAMETER ( NIN = 5 )
INTEGER NSUBS
PARAMETER ( NSUBS = 16 )
- DOUBLE PRECISION ZERO, HALF, ONE
- PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER NMAX, INCMAX
PARAMETER ( NMAX = 65, INCMAX = 2 )
INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
@@ -121,7 +167,7 @@
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
- OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
+ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
@@ -130,7 +176,7 @@
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
- OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
+ OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
@@ -235,14 +281,7 @@
*
* Compute EPS (the machine precision).
*
- EPS = ONE
- 90 CONTINUE
- IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
- $ GO TO 100
- EPS = HALF*EPS
- GO TO 90
- 100 CONTINUE
- EPS = EPS + EPS
+ EPS = EPSILON(ZERO)
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of DMVCH using exact data.
@@ -2982,7 +3021,6 @@
50 CONTINUE
END IF
*
- 60 CONTINUE
LDERES = .TRUE.
GO TO 80
70 CONTINUE
diff --git a/blas/testing/dblat3.f b/blas/testing/dblat3.f
index 082e03e..8d37c74 100644
--- a/blas/testing/dblat3.f
+++ b/blas/testing/dblat3.f
@@ -1,55 +1,101 @@
+*> \brief \b DBLAT3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM DBLAT3
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the DOUBLE PRECISION Level 3 Blas.
+*>
+*> The program must be driven by a short data file. The first 14 records
+*> of the file are read using list-directed input, the last 6 records
+*> are read using the format ( A6, L2 ). An annotated example of a data
+*> file can be obtained by deleting the first 3 characters from the
+*> following 20 lines:
+*> 'dblat3.out' NAME OF SUMMARY OUTPUT FILE
+*> 6 UNIT NUMBER OF SUMMARY FILE
+*> 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+*> F LOGICAL FLAG, T TO STOP ON FAILURES.
+*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
+*> 16.0 THRESHOLD VALUE OF TEST RATIO
+*> 6 NUMBER OF VALUES OF N
+*> 0 1 2 3 5 9 VALUES OF N
+*> 3 NUMBER OF VALUES OF ALPHA
+*> 0.0 1.0 0.7 VALUES OF ALPHA
+*> 3 NUMBER OF VALUES OF BETA
+*> 0.0 1.0 1.3 VALUES OF BETA
+*> DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+*> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
+*>
+*> Further Details
+*> ===============
+*>
+*> See:
+*>
+*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
+*> A Set of Level 3 Basic Linear Algebra Subprograms.
+*>
+*> Technical Memorandum No.88 (Revision 1), Mathematics and
+*> Computer Science Division, Argonne National Laboratory, 9700
+*> South Cass Avenue, Argonne, Illinois 60439, US.
+*>
+*> -- Written on 8-February-1989.
+*> Jack Dongarra, Argonne National Laboratory.
+*> Iain Duff, AERE Harwell.
+*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*> Sven Hammarling, Numerical Algorithms Group Ltd.
+*>
+*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+*> can be run multiple times without deleting generated
+*> output files (susan)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup double_blas_testing
+*
+* =====================================================================
PROGRAM DBLAT3
*
-* Test program for the DOUBLE PRECISION Level 3 Blas.
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
*
-* The program must be driven by a short data file. The first 14 records
-* of the file are read using list-directed input, the last 6 records
-* are read using the format ( A6, L2 ). An annotated example of a data
-* file can be obtained by deleting the first 3 characters from the
-* following 20 lines:
-* 'DBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE
-* 6 UNIT NUMBER OF SUMMARY FILE
-* 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
-* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-* F LOGICAL FLAG, T TO STOP ON FAILURES.
-* T LOGICAL FLAG, T TO TEST ERROR EXITS.
-* 16.0 THRESHOLD VALUE OF TEST RATIO
-* 6 NUMBER OF VALUES OF N
-* 0 1 2 3 5 9 VALUES OF N
-* 3 NUMBER OF VALUES OF ALPHA
-* 0.0 1.0 0.7 VALUES OF ALPHA
-* 3 NUMBER OF VALUES OF BETA
-* 0.0 1.0 1.3 VALUES OF BETA
-* DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
-* DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
-* DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
-* DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
-* DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
-* DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
-*
-* See:
-*
-* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
-* A Set of Level 3 Basic Linear Algebra Subprograms.
-*
-* Technical Memorandum No.88 (Revision 1), Mathematics and
-* Computer Science Division, Argonne National Laboratory, 9700
-* South Cass Avenue, Argonne, Illinois 60439, US.
-*
-* -- Written on 8-February-1989.
-* Jack Dongarra, Argonne National Laboratory.
-* Iain Duff, AERE Harwell.
-* Jeremy Du Croz, Numerical Algorithms Group Ltd.
-* Sven Hammarling, Numerical Algorithms Group Ltd.
+* =====================================================================
*
* .. Parameters ..
INTEGER NIN
PARAMETER ( NIN = 5 )
INTEGER NSUBS
PARAMETER ( NSUBS = 6 )
- DOUBLE PRECISION ZERO, HALF, ONE
- PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER NMAX
PARAMETER ( NMAX = 65 )
INTEGER NIDMAX, NALMAX, NBEMAX
@@ -96,7 +142,7 @@
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
- OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
+ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
@@ -105,7 +151,7 @@
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
- OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
+ OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
@@ -182,14 +228,7 @@
*
* Compute EPS (the machine precision).
*
- EPS = ONE
- 70 CONTINUE
- IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
- $ GO TO 80
- EPS = HALF*EPS
- GO TO 70
- 80 CONTINUE
- EPS = EPS + EPS
+ EPS = EPSILON(ZERO)
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of DMMCH using exact data.
@@ -1802,7 +1841,7 @@
*
* Tests the error exits from the Level 3 Blas.
* Requires a special version of the error-handling routine XERBLA.
-* ALPHA, BETA, A, B and C should not need to be defined.
+* A, B and C should not need to be defined.
*
* Auxiliary routine for test program for Level 3 Blas.
*
@@ -1812,12 +1851,18 @@
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
+* 3-19-92: Initialize ALPHA and BETA (eca)
+* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca)
+*
* .. Scalar Arguments ..
INTEGER ISNUM, NOUT
CHARACTER*6 SRNAMT
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
+* .. Parameters ..
+ DOUBLE PRECISION ONE, TWO
+ PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, BETA
* .. Local Arrays ..
@@ -1834,6 +1879,12 @@
* LERR is set to .TRUE. by the special version of XERBLA each time
* it is called, and is then tested and re-set by CHKXER.
LERR = .FALSE.
+*
+* Initialize ALPHA and BETA.
+*
+ ALPHA = ONE
+ BETA = TWO
+*
GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
10 INFOT = 1
CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
@@ -1963,16 +2014,16 @@
CALL DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
@@ -2660,7 +2711,6 @@
50 CONTINUE
END IF
*
- 60 CONTINUE
LDERES = .TRUE.
GO TO 80
70 CONTINUE
diff --git a/blas/testing/sblat2.f b/blas/testing/sblat2.f
index 057a854..71605ed 100644
--- a/blas/testing/sblat2.f
+++ b/blas/testing/sblat2.f
@@ -1,75 +1,121 @@
+*> \brief \b SBLAT2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM SBLAT2
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the REAL Level 2 Blas.
+*>
+*> The program must be driven by a short data file. The first 18 records
+*> of the file are read using list-directed input, the last 16 records
+*> are read using the format ( A6, L2 ). An annotated example of a data
+*> file can be obtained by deleting the first 3 characters from the
+*> following 34 lines:
+*> 'sblat2.out' NAME OF SUMMARY OUTPUT FILE
+*> 6 UNIT NUMBER OF SUMMARY FILE
+*> 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+*> F LOGICAL FLAG, T TO STOP ON FAILURES.
+*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
+*> 16.0 THRESHOLD VALUE OF TEST RATIO
+*> 6 NUMBER OF VALUES OF N
+*> 0 1 2 3 5 9 VALUES OF N
+*> 4 NUMBER OF VALUES OF K
+*> 0 1 2 4 VALUES OF K
+*> 4 NUMBER OF VALUES OF INCX AND INCY
+*> 1 2 -1 -2 VALUES OF INCX AND INCY
+*> 3 NUMBER OF VALUES OF ALPHA
+*> 0.0 1.0 0.7 VALUES OF ALPHA
+*> 3 NUMBER OF VALUES OF BETA
+*> 0.0 1.0 0.9 VALUES OF BETA
+*> SGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> SGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSYMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSPMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> STRMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> STBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> STPMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> STRSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> STBSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> STPSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> SGER T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSYR T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSPR T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
+*>
+*> Further Details
+*> ===============
+*>
+*> See:
+*>
+*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
+*> An extended set of Fortran Basic Linear Algebra Subprograms.
+*>
+*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
+*> and Computer Science Division, Argonne National Laboratory,
+*> 9700 South Cass Avenue, Argonne, Illinois 60439, US.
+*>
+*> Or
+*>
+*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
+*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
+*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
+*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
+*>
+*>
+*> -- Written on 10-August-1987.
+*> Richard Hanson, Sandia National Labs.
+*> Jeremy Du Croz, NAG Central Office.
+*>
+*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+*> can be run multiple times without deleting generated
+*> output files (susan)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup single_blas_testing
+*
+* =====================================================================
PROGRAM SBLAT2
*
-* Test program for the REAL Level 2 Blas.
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
*
-* The program must be driven by a short data file. The first 18 records
-* of the file are read using list-directed input, the last 16 records
-* are read using the format ( A6, L2 ). An annotated example of a data
-* file can be obtained by deleting the first 3 characters from the
-* following 34 lines:
-* 'SBLAT2.SUMM' NAME OF SUMMARY OUTPUT FILE
-* 6 UNIT NUMBER OF SUMMARY FILE
-* 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
-* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-* F LOGICAL FLAG, T TO STOP ON FAILURES.
-* T LOGICAL FLAG, T TO TEST ERROR EXITS.
-* 16.0 THRESHOLD VALUE OF TEST RATIO
-* 6 NUMBER OF VALUES OF N
-* 0 1 2 3 5 9 VALUES OF N
-* 4 NUMBER OF VALUES OF K
-* 0 1 2 4 VALUES OF K
-* 4 NUMBER OF VALUES OF INCX AND INCY
-* 1 2 -1 -2 VALUES OF INCX AND INCY
-* 3 NUMBER OF VALUES OF ALPHA
-* 0.0 1.0 0.7 VALUES OF ALPHA
-* 3 NUMBER OF VALUES OF BETA
-* 0.0 1.0 0.9 VALUES OF BETA
-* SGEMV T PUT F FOR NO TEST. SAME COLUMNS.
-* SGBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* SSYMV T PUT F FOR NO TEST. SAME COLUMNS.
-* SSBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* SSPMV T PUT F FOR NO TEST. SAME COLUMNS.
-* STRMV T PUT F FOR NO TEST. SAME COLUMNS.
-* STBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* STPMV T PUT F FOR NO TEST. SAME COLUMNS.
-* STRSV T PUT F FOR NO TEST. SAME COLUMNS.
-* STBSV T PUT F FOR NO TEST. SAME COLUMNS.
-* STPSV T PUT F FOR NO TEST. SAME COLUMNS.
-* SGER T PUT F FOR NO TEST. SAME COLUMNS.
-* SSYR T PUT F FOR NO TEST. SAME COLUMNS.
-* SSPR T PUT F FOR NO TEST. SAME COLUMNS.
-* SSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
-* SSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
-*
-* See:
-*
-* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
-* An extended set of Fortran Basic Linear Algebra Subprograms.
-*
-* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
-* and Computer Science Division, Argonne National Laboratory,
-* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
-*
-* Or
-*
-* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
-* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
-* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
-* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
-*
-*
-* -- Written on 10-August-1987.
-* Richard Hanson, Sandia National Labs.
-* Jeremy Du Croz, NAG Central Office.
+* =====================================================================
*
* .. Parameters ..
INTEGER NIN
PARAMETER ( NIN = 5 )
INTEGER NSUBS
PARAMETER ( NSUBS = 16 )
- REAL ZERO, HALF, ONE
- PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0, ONE = 1.0 )
INTEGER NMAX, INCMAX
PARAMETER ( NMAX = 65, INCMAX = 2 )
INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
@@ -121,7 +167,7 @@
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
- OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
+ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
@@ -130,7 +176,7 @@
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
- OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
+ OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
@@ -235,14 +281,7 @@
*
* Compute EPS (the machine precision).
*
- EPS = ONE
- 90 CONTINUE
- IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO )
- $ GO TO 100
- EPS = HALF*EPS
- GO TO 90
- 100 CONTINUE
- EPS = EPS + EPS
+ EPS = EPSILON(ZERO)
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of SMVCH using exact data.
@@ -2982,7 +3021,6 @@
50 CONTINUE
END IF
*
- 60 CONTINUE
LSERES = .TRUE.
GO TO 80
70 CONTINUE
diff --git a/blas/testing/sblat3.f b/blas/testing/sblat3.f
index 325a9eb..8792696 100644
--- a/blas/testing/sblat3.f
+++ b/blas/testing/sblat3.f
@@ -1,55 +1,101 @@
+*> \brief \b SBLAT3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM SBLAT3
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the REAL Level 3 Blas.
+*>
+*> The program must be driven by a short data file. The first 14 records
+*> of the file are read using list-directed input, the last 6 records
+*> are read using the format ( A6, L2 ). An annotated example of a data
+*> file can be obtained by deleting the first 3 characters from the
+*> following 20 lines:
+*> 'sblat3.out' NAME OF SUMMARY OUTPUT FILE
+*> 6 UNIT NUMBER OF SUMMARY FILE
+*> 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+*> F LOGICAL FLAG, T TO STOP ON FAILURES.
+*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
+*> 16.0 THRESHOLD VALUE OF TEST RATIO
+*> 6 NUMBER OF VALUES OF N
+*> 0 1 2 3 5 9 VALUES OF N
+*> 3 NUMBER OF VALUES OF ALPHA
+*> 0.0 1.0 0.7 VALUES OF ALPHA
+*> 3 NUMBER OF VALUES OF BETA
+*> 0.0 1.0 1.3 VALUES OF BETA
+*> SGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> STRMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> STRSM T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+*> SSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
+*>
+*> Further Details
+*> ===============
+*>
+*> See:
+*>
+*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
+*> A Set of Level 3 Basic Linear Algebra Subprograms.
+*>
+*> Technical Memorandum No.88 (Revision 1), Mathematics and
+*> Computer Science Division, Argonne National Laboratory, 9700
+*> South Cass Avenue, Argonne, Illinois 60439, US.
+*>
+*> -- Written on 8-February-1989.
+*> Jack Dongarra, Argonne National Laboratory.
+*> Iain Duff, AERE Harwell.
+*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*> Sven Hammarling, Numerical Algorithms Group Ltd.
+*>
+*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+*> can be run multiple times without deleting generated
+*> output files (susan)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup single_blas_testing
+*
+* =====================================================================
PROGRAM SBLAT3
*
-* Test program for the REAL Level 3 Blas.
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
*
-* The program must be driven by a short data file. The first 14 records
-* of the file are read using list-directed input, the last 6 records
-* are read using the format ( A6, L2 ). An annotated example of a data
-* file can be obtained by deleting the first 3 characters from the
-* following 20 lines:
-* 'SBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE
-* 6 UNIT NUMBER OF SUMMARY FILE
-* 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
-* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-* F LOGICAL FLAG, T TO STOP ON FAILURES.
-* T LOGICAL FLAG, T TO TEST ERROR EXITS.
-* 16.0 THRESHOLD VALUE OF TEST RATIO
-* 6 NUMBER OF VALUES OF N
-* 0 1 2 3 5 9 VALUES OF N
-* 3 NUMBER OF VALUES OF ALPHA
-* 0.0 1.0 0.7 VALUES OF ALPHA
-* 3 NUMBER OF VALUES OF BETA
-* 0.0 1.0 1.3 VALUES OF BETA
-* SGEMM T PUT F FOR NO TEST. SAME COLUMNS.
-* SSYMM T PUT F FOR NO TEST. SAME COLUMNS.
-* STRMM T PUT F FOR NO TEST. SAME COLUMNS.
-* STRSM T PUT F FOR NO TEST. SAME COLUMNS.
-* SSYRK T PUT F FOR NO TEST. SAME COLUMNS.
-* SSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
-*
-* See:
-*
-* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
-* A Set of Level 3 Basic Linear Algebra Subprograms.
-*
-* Technical Memorandum No.88 (Revision 1), Mathematics and
-* Computer Science Division, Argonne National Laboratory, 9700
-* South Cass Avenue, Argonne, Illinois 60439, US.
-*
-* -- Written on 8-February-1989.
-* Jack Dongarra, Argonne National Laboratory.
-* Iain Duff, AERE Harwell.
-* Jeremy Du Croz, Numerical Algorithms Group Ltd.
-* Sven Hammarling, Numerical Algorithms Group Ltd.
+* =====================================================================
*
* .. Parameters ..
INTEGER NIN
PARAMETER ( NIN = 5 )
INTEGER NSUBS
PARAMETER ( NSUBS = 6 )
- REAL ZERO, HALF, ONE
- PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0, ONE = 1.0 )
INTEGER NMAX
PARAMETER ( NMAX = 65 )
INTEGER NIDMAX, NALMAX, NBEMAX
@@ -96,7 +142,7 @@
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
- OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
+ OPEN( NOUT, FILE = SUMMRY )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
@@ -105,7 +151,7 @@
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
- OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
+ OPEN( NTRA, FILE = SNAPS )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
@@ -182,14 +228,7 @@
*
* Compute EPS (the machine precision).
*
- EPS = ONE
- 70 CONTINUE
- IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO )
- $ GO TO 80
- EPS = HALF*EPS
- GO TO 70
- 80 CONTINUE
- EPS = EPS + EPS
+ EPS = EPSILON(ZERO)
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of SMMCH using exact data.
@@ -1802,7 +1841,7 @@
*
* Tests the error exits from the Level 3 Blas.
* Requires a special version of the error-handling routine XERBLA.
-* ALPHA, BETA, A, B and C should not need to be defined.
+* A, B and C should not need to be defined.
*
* Auxiliary routine for test program for Level 3 Blas.
*
@@ -1812,12 +1851,18 @@
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
+* 3-19-92: Initialize ALPHA and BETA (eca)
+* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca)
+*
* .. Scalar Arguments ..
INTEGER ISNUM, NOUT
CHARACTER*6 SRNAMT
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
+* .. Parameters ..
+ REAL ONE, TWO
+ PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 )
* .. Local Scalars ..
REAL ALPHA, BETA
* .. Local Arrays ..
@@ -1834,6 +1879,12 @@
* LERR is set to .TRUE. by the special version of XERBLA each time
* it is called, and is then tested and re-set by CHKXER.
LERR = .FALSE.
+*
+* Initialize ALPHA and BETA.
+*
+ ALPHA = ONE
+ BETA = TWO
+*
GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
10 INFOT = 1
CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
@@ -1963,16 +2014,16 @@
CALL SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
@@ -2660,7 +2711,6 @@
50 CONTINUE
END IF
*
- 60 CONTINUE
LSERES = .TRUE.
GO TO 80
70 CONTINUE
diff --git a/blas/testing/zblat1.f b/blas/testing/zblat1.f
index e2415e1..d30112c 100644
--- a/blas/testing/zblat1.f
+++ b/blas/testing/zblat1.f
@@ -1,7 +1,49 @@
+*> \brief \b ZBLAT1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM ZBLAT1
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the COMPLEX*16 Level 1 BLAS.
+*>
+*> Based upon the original BLAS test routine together with:
+*> F06GAF Example Program Text
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup complex16_blas_testing
+*
+* =====================================================================
PROGRAM ZBLAT1
-* Test program for the COMPLEX*16 Level 1 BLAS.
-* Based upon the original BLAS test routine together with:
-* F06GAF Example Program Text
+*
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* =====================================================================
+*
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
@@ -114,8 +156,8 @@
+ (5.0D0,6.0D0), (5.0D0,6.0D0), (0.1D0,0.1D0),
+ (-0.6D0,0.1D0), (0.1D0,-0.3D0), (7.0D0,8.0D0),
+ (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
- + (7.0D0,8.0D0), (0.3D0,0.1D0), (0.1D0,0.4D0),
- + (0.4D0,0.1D0), (0.1D0,0.2D0), (2.0D0,3.0D0),
+ + (7.0D0,8.0D0), (0.3D0,0.1D0), (0.5D0,0.0D0),
+ + (0.0D0,0.5D0), (0.0D0,0.2D0), (2.0D0,3.0D0),
+ (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0)/
DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0),
+ (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
@@ -129,10 +171,10 @@
+ (3.0D0,6.0D0), (-0.6D0,0.1D0), (4.0D0,7.0D0),
+ (0.1D0,-0.3D0), (7.0D0,2.0D0), (7.0D0,2.0D0),
+ (7.0D0,2.0D0), (0.3D0,0.1D0), (5.0D0,8.0D0),
- + (0.1D0,0.4D0), (6.0D0,9.0D0), (0.4D0,0.1D0),
- + (8.0D0,3.0D0), (0.1D0,0.2D0), (9.0D0,4.0D0)/
- DATA STRUE2/0.0D0, 0.5D0, 0.6D0, 0.7D0, 0.7D0/
- DATA STRUE4/0.0D0, 0.7D0, 1.0D0, 1.3D0, 1.7D0/
+ + (0.5D0,0.0D0), (6.0D0,9.0D0), (0.0D0,0.5D0),
+ + (8.0D0,3.0D0), (0.0D0,0.2D0), (9.0D0,4.0D0)/
+ DATA STRUE2/0.0D0, 0.5D0, 0.6D0, 0.7D0, 0.8D0/
+ DATA STRUE4/0.0D0, 0.7D0, 1.0D0, 1.3D0, 1.6D0/
DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0),
+ (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
+ (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
@@ -145,8 +187,8 @@
+ (0.11D0,-0.03D0), (-0.17D0,0.46D0),
+ (-0.17D0,-0.19D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
+ (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
- + (0.19D0,-0.17D0), (0.32D0,0.09D0),
- + (0.23D0,-0.24D0), (0.18D0,0.01D0),
+ + (0.19D0,-0.17D0), (0.20D0,-0.35D0),
+ + (0.35D0,0.20D0), (0.14D0,0.08D0),
+ (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0),
+ (2.0D0,3.0D0)/
DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0),
@@ -162,9 +204,9 @@
+ (-0.17D0,0.46D0), (4.0D0,7.0D0),
+ (-0.17D0,-0.19D0), (7.0D0,2.0D0), (7.0D0,2.0D0),
+ (7.0D0,2.0D0), (0.19D0,-0.17D0), (5.0D0,8.0D0),
- + (0.32D0,0.09D0), (6.0D0,9.0D0),
- + (0.23D0,-0.24D0), (8.0D0,3.0D0),
- + (0.18D0,0.01D0), (9.0D0,4.0D0)/
+ + (0.20D0,-0.35D0), (6.0D0,9.0D0),
+ + (0.35D0,0.20D0), (8.0D0,3.0D0),
+ + (0.14D0,0.08D0), (9.0D0,4.0D0)/
DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0),
+ (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
+ (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
@@ -177,8 +219,8 @@
+ (0.03D0,0.03D0), (-0.18D0,0.03D0),
+ (0.03D0,-0.09D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
+ (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
- + (0.09D0,0.03D0), (0.03D0,0.12D0),
- + (0.12D0,0.03D0), (0.03D0,0.06D0), (2.0D0,3.0D0),
+ + (0.09D0,0.03D0), (0.15D0,0.00D0),
+ + (0.00D0,0.15D0), (0.00D0,0.06D0), (2.0D0,3.0D0),
+ (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0)/
DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0),
+ (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
@@ -193,8 +235,8 @@
+ (-0.18D0,0.03D0), (4.0D0,7.0D0),
+ (0.03D0,-0.09D0), (7.0D0,2.0D0), (7.0D0,2.0D0),
+ (7.0D0,2.0D0), (0.09D0,0.03D0), (5.0D0,8.0D0),
- + (0.03D0,0.12D0), (6.0D0,9.0D0), (0.12D0,0.03D0),
- + (8.0D0,3.0D0), (0.03D0,0.06D0), (9.0D0,4.0D0)/
+ + (0.15D0,0.00D0), (6.0D0,9.0D0), (0.00D0,0.15D0),
+ + (8.0D0,3.0D0), (0.00D0,0.06D0), (9.0D0,4.0D0)/
DATA ITRUE3/0, 1, 2, 2, 2/
* .. Executable Statements ..
DO 60 INCX = 1, 2
@@ -529,7 +571,8 @@
*
* .. Parameters ..
INTEGER NOUT
- PARAMETER (NOUT=6)
+ DOUBLE PRECISION ZERO
+ PARAMETER (NOUT=6, ZERO=0.0D0)
* .. Scalar Arguments ..
DOUBLE PRECISION SFAC
INTEGER LEN
@@ -552,7 +595,7 @@
*
DO 40 I = 1, LEN
SD = SCOMP(I) - STRUE(I)
- IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0D0)
+ IF (ABS(SFAC*SD) .LE. ABS(SSIZE(I))*EPSILON(ZERO))
+ GO TO 40
*
* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
diff --git a/blas/testing/zblat2.f b/blas/testing/zblat2.f
index e65cdcc..53129a1 100644
--- a/blas/testing/zblat2.f
+++ b/blas/testing/zblat2.f
@@ -1,68 +1,114 @@
+*> \brief \b ZBLAT2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM ZBLAT2
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the COMPLEX*16 Level 2 Blas.
+*>
+*> The program must be driven by a short data file. The first 18 records
+*> of the file are read using list-directed input, the last 17 records
+*> are read using the format ( A6, L2 ). An annotated example of a data
+*> file can be obtained by deleting the first 3 characters from the
+*> following 35 lines:
+*> 'zblat2.out' NAME OF SUMMARY OUTPUT FILE
+*> 6 UNIT NUMBER OF SUMMARY FILE
+*> 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+*> F LOGICAL FLAG, T TO STOP ON FAILURES.
+*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
+*> 16.0 THRESHOLD VALUE OF TEST RATIO
+*> 6 NUMBER OF VALUES OF N
+*> 0 1 2 3 5 9 VALUES OF N
+*> 4 NUMBER OF VALUES OF K
+*> 0 1 2 4 VALUES OF K
+*> 4 NUMBER OF VALUES OF INCX AND INCY
+*> 1 2 -1 -2 VALUES OF INCX AND INCY
+*> 3 NUMBER OF VALUES OF ALPHA
+*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
+*> 3 NUMBER OF VALUES OF BETA
+*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
+*> ZGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHEMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHPMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZTRMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZTBMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZTPMV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZTRSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZTBSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZTPSV T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZGERC T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZGERU T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHER T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHPR T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHER2 T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHPR2 T PUT F FOR NO TEST. SAME COLUMNS.
+*>
+*> Further Details
+*> ===============
+*>
+*> See:
+*>
+*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
+*> An extended set of Fortran Basic Linear Algebra Subprograms.
+*>
+*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
+*> and Computer Science Division, Argonne National Laboratory,
+*> 9700 South Cass Avenue, Argonne, Illinois 60439, US.
+*>
+*> Or
+*>
+*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
+*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
+*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
+*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
+*>
+*>
+*> -- Written on 10-August-1987.
+*> Richard Hanson, Sandia National Labs.
+*> Jeremy Du Croz, NAG Central Office.
+*>
+*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+*> can be run multiple times without deleting generated
+*> output files (susan)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup complex16_blas_testing
+*
+* =====================================================================
PROGRAM ZBLAT2
*
-* Test program for the COMPLEX*16 Level 2 Blas.
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
*
-* The program must be driven by a short data file. The first 18 records
-* of the file are read using list-directed input, the last 17 records
-* are read using the format ( A6, L2 ). An annotated example of a data
-* file can be obtained by deleting the first 3 characters from the
-* following 35 lines:
-* 'ZBLAT2.SUMM' NAME OF SUMMARY OUTPUT FILE
-* 6 UNIT NUMBER OF SUMMARY FILE
-* 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
-* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-* F LOGICAL FLAG, T TO STOP ON FAILURES.
-* T LOGICAL FLAG, T TO TEST ERROR EXITS.
-* 16.0 THRESHOLD VALUE OF TEST RATIO
-* 6 NUMBER OF VALUES OF N
-* 0 1 2 3 5 9 VALUES OF N
-* 4 NUMBER OF VALUES OF K
-* 0 1 2 4 VALUES OF K
-* 4 NUMBER OF VALUES OF INCX AND INCY
-* 1 2 -1 -2 VALUES OF INCX AND INCY
-* 3 NUMBER OF VALUES OF ALPHA
-* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
-* 3 NUMBER OF VALUES OF BETA
-* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
-* ZGEMV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZGBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHEMV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHPMV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZTRMV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZTBMV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZTPMV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZTRSV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZTBSV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZTPSV T PUT F FOR NO TEST. SAME COLUMNS.
-* ZGERC T PUT F FOR NO TEST. SAME COLUMNS.
-* ZGERU T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHER T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHPR T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHER2 T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHPR2 T PUT F FOR NO TEST. SAME COLUMNS.
-*
-* See:
-*
-* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
-* An extended set of Fortran Basic Linear Algebra Subprograms.
-*
-* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
-* and Computer Science Division, Argonne National Laboratory,
-* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
-*
-* Or
-*
-* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
-* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
-* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
-* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
-*
-*
-* -- Written on 10-August-1987.
-* Richard Hanson, Sandia National Labs.
-* Jeremy Du Croz, NAG Central Office.
+* =====================================================================
*
* .. Parameters ..
INTEGER NIN
@@ -72,8 +118,8 @@
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
$ ONE = ( 1.0D0, 0.0D0 ) )
- DOUBLE PRECISION RZERO, RHALF, RONE
- PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 )
+ DOUBLE PRECISION RZERO
+ PARAMETER ( RZERO = 0.0D0 )
INTEGER NMAX, INCMAX
PARAMETER ( NMAX = 65, INCMAX = 2 )
INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
@@ -127,7 +173,7 @@
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
- OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
+ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
@@ -136,7 +182,7 @@
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
- OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
+ OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
@@ -241,14 +287,7 @@
*
* Compute EPS (the machine precision).
*
- EPS = RONE
- 90 CONTINUE
- IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO )
- $ GO TO 100
- EPS = RHALF*EPS
- GO TO 90
- 100 CONTINUE
- EPS = EPS + EPS
+ EPS = EPSILON(RZERO)
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of ZMVCH using exact data.
@@ -3087,7 +3126,6 @@
50 CONTINUE
END IF
*
- 60 CONTINUE
LZERES = .TRUE.
GO TO 80
70 CONTINUE
diff --git a/blas/testing/zblat3.f b/blas/testing/zblat3.f
index d6a522f..59ca241 100644
--- a/blas/testing/zblat3.f
+++ b/blas/testing/zblat3.f
@@ -1,50 +1,97 @@
+*> \brief \b ZBLAT3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* PROGRAM ZBLAT3
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Test program for the COMPLEX*16 Level 3 Blas.
+*>
+*> The program must be driven by a short data file. The first 14 records
+*> of the file are read using list-directed input, the last 9 records
+*> are read using the format ( A6, L2 ). An annotated example of a data
+*> file can be obtained by deleting the first 3 characters from the
+*> following 23 lines:
+*> 'zblat3.out' NAME OF SUMMARY OUTPUT FILE
+*> 6 UNIT NUMBER OF SUMMARY FILE
+*> 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+*> F LOGICAL FLAG, T TO STOP ON FAILURES.
+*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
+*> 16.0 THRESHOLD VALUE OF TEST RATIO
+*> 6 NUMBER OF VALUES OF N
+*> 0 1 2 3 5 9 VALUES OF N
+*> 3 NUMBER OF VALUES OF ALPHA
+*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
+*> 3 NUMBER OF VALUES OF BETA
+*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
+*> ZGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHEMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZTRMM T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZTRSM T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHERK T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZHER2K T PUT F FOR NO TEST. SAME COLUMNS.
+*> ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
+*>
+*>
+*> Further Details
+*> ===============
+*>
+*> See:
+*>
+*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
+*> A Set of Level 3 Basic Linear Algebra Subprograms.
+*>
+*> Technical Memorandum No.88 (Revision 1), Mathematics and
+*> Computer Science Division, Argonne National Laboratory, 9700
+*> South Cass Avenue, Argonne, Illinois 60439, US.
+*>
+*> -- Written on 8-February-1989.
+*> Jack Dongarra, Argonne National Laboratory.
+*> Iain Duff, AERE Harwell.
+*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*> Sven Hammarling, Numerical Algorithms Group Ltd.
+*>
+*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+*> can be run multiple times without deleting generated
+*> output files (susan)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup complex16_blas_testing
+*
+* =====================================================================
PROGRAM ZBLAT3
*
-* Test program for the COMPLEX*16 Level 3 Blas.
+* -- Reference BLAS test routine (version 3.4.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
*
-* The program must be driven by a short data file. The first 14 records
-* of the file are read using list-directed input, the last 9 records
-* are read using the format ( A6, L2 ). An annotated example of a data
-* file can be obtained by deleting the first 3 characters from the
-* following 23 lines:
-* 'ZBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE
-* 6 UNIT NUMBER OF SUMMARY FILE
-* 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
-* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-* F LOGICAL FLAG, T TO STOP ON FAILURES.
-* T LOGICAL FLAG, T TO TEST ERROR EXITS.
-* 16.0 THRESHOLD VALUE OF TEST RATIO
-* 6 NUMBER OF VALUES OF N
-* 0 1 2 3 5 9 VALUES OF N
-* 3 NUMBER OF VALUES OF ALPHA
-* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
-* 3 NUMBER OF VALUES OF BETA
-* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
-* ZGEMM T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHEMM T PUT F FOR NO TEST. SAME COLUMNS.
-* ZSYMM T PUT F FOR NO TEST. SAME COLUMNS.
-* ZTRMM T PUT F FOR NO TEST. SAME COLUMNS.
-* ZTRSM T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHERK T PUT F FOR NO TEST. SAME COLUMNS.
-* ZSYRK T PUT F FOR NO TEST. SAME COLUMNS.
-* ZHER2K T PUT F FOR NO TEST. SAME COLUMNS.
-* ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
-*
-* See:
-*
-* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
-* A Set of Level 3 Basic Linear Algebra Subprograms.
-*
-* Technical Memorandum No.88 (Revision 1), Mathematics and
-* Computer Science Division, Argonne National Laboratory, 9700
-* South Cass Avenue, Argonne, Illinois 60439, US.
-*
-* -- Written on 8-February-1989.
-* Jack Dongarra, Argonne National Laboratory.
-* Iain Duff, AERE Harwell.
-* Jeremy Du Croz, Numerical Algorithms Group Ltd.
-* Sven Hammarling, Numerical Algorithms Group Ltd.
+* =====================================================================
*
* .. Parameters ..
INTEGER NIN
@@ -54,8 +101,8 @@
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
$ ONE = ( 1.0D0, 0.0D0 ) )
- DOUBLE PRECISION RZERO, RHALF, RONE
- PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 )
+ DOUBLE PRECISION RZERO
+ PARAMETER ( RZERO = 0.0D0 )
INTEGER NMAX
PARAMETER ( NMAX = 65 )
INTEGER NIDMAX, NALMAX, NBEMAX
@@ -104,7 +151,7 @@
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
- OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
+ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
@@ -113,7 +160,7 @@
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
- OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
+ OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
@@ -190,14 +237,7 @@
*
* Compute EPS (the machine precision).
*
- EPS = RONE
- 70 CONTINUE
- IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO )
- $ GO TO 80
- EPS = RHALF*EPS
- GO TO 70
- 80 CONTINUE
- EPS = EPS + EPS
+ EPS = EPSILON(RZERO)
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of ZMMCH using exact data.
@@ -1949,7 +1989,7 @@
*
* Tests the error exits from the Level 3 Blas.
* Requires a special version of the error-handling routine XERBLA.
-* ALPHA, RALPHA, BETA, RBETA, A, B and C should not need to be defined.
+* A, B and C should not need to be defined.
*
* Auxiliary routine for test program for Level 3 Blas.
*
@@ -1959,12 +1999,20 @@
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
+* 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca)
+* 3-19-92: Fix argument 12 in calls to ZSYMM and ZHEMM
+* with INFOT = 9 (eca)
+* 10-9-00: Declared INTRINSIC DCMPLX (susan)
+*
* .. Scalar Arguments ..
INTEGER ISNUM, NOUT
CHARACTER*6 SRNAMT
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
+* .. Parameters ..
+ REAL ONE, TWO
+ PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 )
* .. Local Scalars ..
COMPLEX*16 ALPHA, BETA
DOUBLE PRECISION RALPHA, RBETA
@@ -1973,6 +2021,8 @@
* .. External Subroutines ..
EXTERNAL ZGEMM, ZHEMM, ZHER2K, ZHERK, CHKXER, ZSYMM,
$ ZSYR2K, ZSYRK, ZTRMM, ZTRSM
+* .. Intrinsic Functions ..
+ INTRINSIC DCMPLX
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Executable Statements ..
@@ -1982,6 +2032,14 @@
* LERR is set to .TRUE. by the special version of XERBLA each time
* it is called, and is then tested and re-set by CHKXER.
LERR = .FALSE.
+*
+* Initialize ALPHA, BETA, RALPHA, and RBETA.
+*
+ ALPHA = DCMPLX( ONE, -ONE )
+ BETA = DCMPLX( TWO, -TWO )
+ RALPHA = ONE
+ RBETA = TWO
+*
GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
$ 90 )ISNUM
10 INFOT = 1
@@ -2208,16 +2266,16 @@
CALL ZHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
@@ -2275,16 +2333,16 @@
CALL ZSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
@@ -3274,7 +3332,6 @@
50 CONTINUE
END IF
*
- 60 CONTINUE
LZERES = .TRUE.
GO TO 80
70 CONTINUE
diff --git a/blas/xerbla.cpp b/blas/xerbla.cpp
index dd39a52..c373e86 100644
--- a/blas/xerbla.cpp
+++ b/blas/xerbla.cpp
@@ -1,5 +1,5 @@
-#include <iostream>
+#include <stdio.h>
#if (defined __GNUC__) && (!defined __MINGW32__) && (!defined __CYGWIN__)
#define EIGEN_WEAK_LINKING __attribute__ ((weak))
@@ -14,7 +14,7 @@
EIGEN_WEAK_LINKING int xerbla_(const char * msg, int *info, int)
{
- std::cerr << "Eigen BLAS ERROR #" << *info << ": " << msg << "\n";
+ printf("Eigen BLAS ERROR #%i: %s\n", *info, msg );
return 0;
}
diff --git a/blas/zhbmv.f b/blas/zhbmv.f
deleted file mode 100644
index bca0da5..0000000
--- a/blas/zhbmv.f
+++ /dev/null
@@ -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
diff --git a/blas/zhpmv.f b/blas/zhpmv.f
deleted file mode 100644
index b686108..0000000
--- a/blas/zhpmv.f
+++ /dev/null
@@ -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
diff --git a/blas/ztbmv.f b/blas/ztbmv.f
deleted file mode 100644
index 7c85c1b..0000000
--- a/blas/ztbmv.f
+++ /dev/null
@@ -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