Disabled external gits

cs440-acg/ext/eigen/blas/BandTriangularSolver.h

@@ -0,0 +1,97 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2011 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#ifndef EIGEN_BAND_TRIANGULARSOLVER_H
+#define EIGEN_BAND_TRIANGULARSOLVER_H
+
+namespace internal {
+
+ /* \internal
+  * Solve Ax=b with A a band triangular matrix
+  * TODO: extend it to matrices for x abd b */
+template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar, int StorageOrder>
+struct band_solve_triangular_selector;
+
+
+template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar>
+struct band_solve_triangular_selector<Index,Mode,LhsScalar,ConjLhs,RhsScalar,RowMajor>
+{
+  typedef Map<const Matrix<LhsScalar,Dynamic,Dynamic,RowMajor>, 0, OuterStride<> > LhsMap;
+  typedef Map<Matrix<RhsScalar,Dynamic,1> > RhsMap;
+  enum { IsLower = (Mode&Lower) ? 1 : 0 };
+  static void run(Index size, Index k, const LhsScalar* _lhs, Index lhsStride, RhsScalar* _other)
+  {
+    const LhsMap lhs(_lhs,size,k+1,OuterStride<>(lhsStride));
+    RhsMap other(_other,size,1);
+    typename internal::conditional<
+                          ConjLhs,
+                          const CwiseUnaryOp<typename internal::scalar_conjugate_op<LhsScalar>,LhsMap>,
+                          const LhsMap&>
+                        ::type cjLhs(lhs);
+                        
+    for(int col=0 ; col<other.cols() ; ++col)
+    {
+      for(int ii=0; ii<size; ++ii)
+      {
+        int i = IsLower ? ii : size-ii-1;
+        int actual_k = (std::min)(k,ii);
+        int actual_start = IsLower ? k-actual_k : 1;
+        
+        if(actual_k>0)
+          other.coeffRef(i,col) -= cjLhs.row(i).segment(actual_start,actual_k).transpose()
+                                  .cwiseProduct(other.col(col).segment(IsLower ? i-actual_k : i+1,actual_k)).sum();
+
+        if((Mode&UnitDiag)==0)
+          other.coeffRef(i,col) /= cjLhs(i,IsLower ? k : 0);
+      }
+    }
+  }
+  
+};
+
+template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar>
+struct band_solve_triangular_selector<Index,Mode,LhsScalar,ConjLhs,RhsScalar,ColMajor>
+{
+  typedef Map<const Matrix<LhsScalar,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> > LhsMap;
+  typedef Map<Matrix<RhsScalar,Dynamic,1> > RhsMap;
+  enum { IsLower = (Mode&Lower) ? 1 : 0 };
+  static void run(Index size, Index k, const LhsScalar* _lhs, Index lhsStride, RhsScalar* _other)
+  {
+    const LhsMap lhs(_lhs,k+1,size,OuterStride<>(lhsStride));
+    RhsMap other(_other,size,1);
+    typename internal::conditional<
+                          ConjLhs,
+                          const CwiseUnaryOp<typename internal::scalar_conjugate_op<LhsScalar>,LhsMap>,
+                          const LhsMap&>
+                        ::type cjLhs(lhs);
+                        
+    for(int col=0 ; col<other.cols() ; ++col)
+    {
+      for(int ii=0; ii<size; ++ii)
+      {
+        int i = IsLower ? ii : size-ii-1;
+        int actual_k = (std::min)(k,size-ii-1);
+        int actual_start = IsLower ? 1 : k-actual_k;
+        
+        if((Mode&UnitDiag)==0)
+          other.coeffRef(i,col) /= cjLhs(IsLower ? 0 : k, i);
+
+        if(actual_k>0)
+          other.col(col).segment(IsLower ? i+1 : i-actual_k, actual_k)
+              -= other.coeff(i,col) * cjLhs.col(i).segment(actual_start,actual_k);
+        
+      }
+    }
+  }
+};
+
+
+} // end namespace internal
+
+#endif // EIGEN_BAND_TRIANGULARSOLVER_H

cs440-acg/ext/eigen/blas/CMakeLists.txt

@@ -0,0 +1,57 @@
+
+project(EigenBlas CXX)
+
+include("../cmake/language_support.cmake")
+
+workaround_9220(Fortran EIGEN_Fortran_COMPILER_WORKS)
+
+if(EIGEN_Fortran_COMPILER_WORKS)
+  enable_language(Fortran OPTIONAL)
+  if(NOT CMAKE_Fortran_COMPILER)
+    set(EIGEN_Fortran_COMPILER_WORKS OFF)
+  endif()
+endif()
+
+add_custom_target(blas)
+
+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} fortran/complexdots.f)
+else()
+  set(EigenBlas_SRCS ${EigenBlas_SRCS} f2c/complexdots.c)
+endif()
+
+add_library(eigen_blas_static ${EigenBlas_SRCS})
+add_library(eigen_blas SHARED ${EigenBlas_SRCS})
+
+if(EIGEN_STANDARD_LIBRARIES_TO_LINK_TO)
+  target_link_libraries(eigen_blas_static ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO})
+  target_link_libraries(eigen_blas        ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO})
+endif()
+
+add_dependencies(blas eigen_blas eigen_blas_static)
+
+install(TARGETS eigen_blas eigen_blas_static
+        RUNTIME DESTINATION bin
+        LIBRARY DESTINATION lib
+        ARCHIVE DESTINATION lib)
+
+if(EIGEN_Fortran_COMPILER_WORKS)
+
+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()
+

cs440-acg/ext/eigen/blas/GeneralRank1Update.h

@@ -0,0 +1,44 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net>
+//
+// 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/.
+
+#ifndef EIGEN_GENERAL_RANK1UPDATE_H
+#define EIGEN_GENERAL_RANK1UPDATE_H
+
+namespace internal {
+
+/* Optimized matrix += alpha * uv' */
+template<typename Scalar, typename Index, int StorageOrder, bool ConjLhs, bool ConjRhs>
+struct general_rank1_update;
+
+template<typename Scalar, typename Index, bool ConjLhs, bool ConjRhs>
+struct general_rank1_update<Scalar,Index,ColMajor,ConjLhs,ConjRhs>
+{
+  static void run(Index rows, Index cols, Scalar* mat, Index stride, const Scalar* u, const Scalar* v, Scalar alpha)
+  {
+    typedef Map<const Matrix<Scalar,Dynamic,1> > OtherMap;
+    typedef typename conj_expr_if<ConjLhs,OtherMap>::type ConjRhsType;
+    conj_if<ConjRhs> cj;
+
+    for (Index i=0; i<cols; ++i)
+      Map<Matrix<Scalar,Dynamic,1> >(mat+stride*i,rows) += alpha * cj(v[i]) * ConjRhsType(OtherMap(u,rows));
+  }
+};
+
+template<typename Scalar, typename Index, bool ConjLhs, bool ConjRhs>
+struct general_rank1_update<Scalar,Index,RowMajor,ConjLhs,ConjRhs>
+{
+  static void run(Index rows, Index cols, Scalar* mat, Index stride, const Scalar* u, const Scalar* v, Scalar alpha)
+  {
+    general_rank1_update<Scalar,Index,ColMajor,ConjRhs,ConjRhs>::run(rows,cols,mat,stride,u,v,alpha);
+  }
+};
+
+} // end namespace internal
+
+#endif // EIGEN_GENERAL_RANK1UPDATE_H

cs440-acg/ext/eigen/blas/PackedSelfadjointProduct.h

@@ -0,0 +1,53 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net>
+//
+// 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/.
+
+#ifndef EIGEN_SELFADJOINT_PACKED_PRODUCT_H
+#define EIGEN_SELFADJOINT_PACKED_PRODUCT_H
+
+namespace internal {
+
+/* Optimized matrix += alpha * uv'
+ * The matrix is in packed form.
+ */
+template<typename Scalar, typename Index, int StorageOrder, int UpLo, bool ConjLhs, bool ConjRhs>
+struct selfadjoint_packed_rank1_update;
+
+template<typename Scalar, typename Index, int UpLo, bool ConjLhs, bool ConjRhs>
+struct selfadjoint_packed_rank1_update<Scalar,Index,ColMajor,UpLo,ConjLhs,ConjRhs>
+{
+  typedef typename NumTraits<Scalar>::Real RealScalar;
+  static void run(Index size, Scalar* mat, const Scalar* vec, RealScalar alpha)
+  {
+    typedef Map<const Matrix<Scalar,Dynamic,1> > OtherMap;
+    typedef typename conj_expr_if<ConjLhs,OtherMap>::type ConjRhsType;
+    conj_if<ConjRhs> cj;
+
+    for (Index i=0; i<size; ++i)
+    {
+      Map<Matrix<Scalar,Dynamic,1> >(mat, UpLo==Lower ? size-i : (i+1)) += alpha * cj(vec[i]) * ConjRhsType(OtherMap(vec+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1)));
+      //FIXME This should be handled outside.
+      mat[UpLo==Lower ? 0 : i] = numext::real(mat[UpLo==Lower ? 0 : i]);
+      mat += UpLo==Lower ? size-i : (i+1);
+    }
+  }
+};
+
+template<typename Scalar, typename Index, int UpLo, bool ConjLhs, bool ConjRhs>
+struct selfadjoint_packed_rank1_update<Scalar,Index,RowMajor,UpLo,ConjLhs,ConjRhs>
+{
+  typedef typename NumTraits<Scalar>::Real RealScalar;
+  static void run(Index size, Scalar* mat, const Scalar* vec, RealScalar alpha)
+  {
+    selfadjoint_packed_rank1_update<Scalar,Index,ColMajor,UpLo==Lower?Upper:Lower,ConjRhs,ConjLhs>::run(size,mat,vec,alpha);
+  }
+};
+
+} // end namespace internal
+
+#endif // EIGEN_SELFADJOINT_PACKED_PRODUCT_H

cs440-acg/ext/eigen/blas/PackedTriangularMatrixVector.h

@@ -0,0 +1,79 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net>
+//
+// 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/.
+
+#ifndef EIGEN_PACKED_TRIANGULAR_MATRIX_VECTOR_H
+#define EIGEN_PACKED_TRIANGULAR_MATRIX_VECTOR_H
+
+namespace internal {
+
+template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar, bool ConjRhs, int StorageOrder>
+struct packed_triangular_matrix_vector_product;
+
+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 ScalarBinaryOpTraits<LhsScalar, RhsScalar>::ReturnType ResScalar;
+  enum {
+    IsLower     = (Mode & Lower)   ==Lower,
+    HasUnitDiag = (Mode & UnitDiag)==UnitDiag,
+    HasZeroDiag = (Mode & ZeroDiag)==ZeroDiag
+  };
+  static void run(Index size, const LhsScalar* lhs, const RhsScalar* rhs, ResScalar* res, ResScalar alpha)
+  {
+    internal::conj_if<ConjRhs> cj;
+    typedef Map<const Matrix<LhsScalar,Dynamic,1> > LhsMap;
+    typedef typename conj_expr_if<ConjLhs,LhsMap>::type ConjLhsType;
+    typedef Map<Matrix<ResScalar,Dynamic,1> > ResMap;
+
+    for (Index i=0; i<size; ++i)
+    {
+      Index s = IsLower&&(HasUnitDiag||HasZeroDiag) ? 1 : 0;
+      Index r = IsLower ? size-i: i+1;
+      if (EIGEN_IMPLIES(HasUnitDiag||HasZeroDiag, (--r)>0))
+	ResMap(res+(IsLower ? s+i : 0),r) += alpha * cj(rhs[i]) * ConjLhsType(LhsMap(lhs+s,r));
+      if (HasUnitDiag)
+	res[i] += alpha * cj(rhs[i]);
+      lhs += IsLower ? size-i: i+1;
+    }
+  };
+};
+
+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 ScalarBinaryOpTraits<LhsScalar, RhsScalar>::ReturnType ResScalar;
+  enum {
+    IsLower     = (Mode & Lower)   ==Lower,
+    HasUnitDiag = (Mode & UnitDiag)==UnitDiag,
+    HasZeroDiag = (Mode & ZeroDiag)==ZeroDiag
+  };
+  static void run(Index size, const LhsScalar* lhs, const RhsScalar* rhs, ResScalar* res, ResScalar alpha)
+  {
+    internal::conj_if<ConjRhs> cj;
+    typedef Map<const Matrix<LhsScalar,Dynamic,1> > LhsMap;
+    typedef typename conj_expr_if<ConjLhs,LhsMap>::type ConjLhsType;
+    typedef Map<const Matrix<RhsScalar,Dynamic,1> > RhsMap;
+    typedef typename conj_expr_if<ConjRhs,RhsMap>::type ConjRhsType;
+
+    for (Index i=0; i<size; ++i)
+    {
+      Index s = !IsLower&&(HasUnitDiag||HasZeroDiag) ? 1 : 0;
+      Index r = IsLower ? i+1 : size-i;
+      if (EIGEN_IMPLIES(HasUnitDiag||HasZeroDiag, (--r)>0))
+	res[i] += alpha * (ConjLhsType(LhsMap(lhs+s,r)).cwiseProduct(ConjRhsType(RhsMap(rhs+(IsLower ? 0 : s+i),r)))).sum();
+      if (HasUnitDiag)
+	res[i] += alpha * cj(rhs[i]);
+      lhs += IsLower ? i+1 : size-i;
+    }
+  };
+};
+
+} // end namespace internal
+
+#endif // EIGEN_PACKED_TRIANGULAR_MATRIX_VECTOR_H

cs440-acg/ext/eigen/blas/PackedTriangularSolverVector.h

@@ -0,0 +1,88 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net>
+//
+// 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/.
+
+#ifndef EIGEN_PACKED_TRIANGULAR_SOLVER_VECTOR_H
+#define EIGEN_PACKED_TRIANGULAR_SOLVER_VECTOR_H
+
+namespace internal {
+
+template<typename LhsScalar, typename RhsScalar, typename Index, int Side, int Mode, bool Conjugate, int StorageOrder>
+struct packed_triangular_solve_vector;
+
+// forward and backward substitution, row-major, rhs is a vector
+template<typename LhsScalar, typename RhsScalar, typename Index, int Mode, bool Conjugate>
+struct packed_triangular_solve_vector<LhsScalar, RhsScalar, Index, OnTheLeft, Mode, Conjugate, RowMajor>
+{
+  enum {
+    IsLower = (Mode&Lower)==Lower
+  };
+  static void run(Index size, const LhsScalar* lhs, RhsScalar* rhs)
+  {
+    internal::conj_if<Conjugate> cj;
+    typedef Map<const Matrix<LhsScalar,Dynamic,1> > LhsMap;
+    typedef typename conj_expr_if<Conjugate,LhsMap>::type ConjLhsType;
+
+    lhs += IsLower ? 0 : (size*(size+1)>>1)-1;
+    for(Index pi=0; pi<size; ++pi)
+    {
+      Index i = IsLower ? pi : size-pi-1;
+      Index s = IsLower ? 0 : 1;
+      if (pi>0)
+	rhs[i] -= (ConjLhsType(LhsMap(lhs+s,pi))
+	    .cwiseProduct(Map<const Matrix<RhsScalar,Dynamic,1> >(rhs+(IsLower ? 0 : i+1),pi))).sum();
+      if (!(Mode & UnitDiag))
+	rhs[i] /= cj(lhs[IsLower ? i : 0]);
+      IsLower ? lhs += pi+1 : lhs -= pi+2;
+    }
+  }
+};
+
+// forward and backward substitution, column-major, rhs is a vector
+template<typename LhsScalar, typename RhsScalar, typename Index, int Mode, bool Conjugate>
+struct packed_triangular_solve_vector<LhsScalar, RhsScalar, Index, OnTheLeft, Mode, Conjugate, ColMajor>
+{
+  enum {
+    IsLower = (Mode&Lower)==Lower
+  };
+  static void run(Index size, const LhsScalar* lhs, RhsScalar* rhs)
+  {
+    internal::conj_if<Conjugate> cj;
+    typedef Map<const Matrix<LhsScalar,Dynamic,1> > LhsMap;
+    typedef typename conj_expr_if<Conjugate,LhsMap>::type ConjLhsType;
+
+    lhs += IsLower ? 0 : size*(size-1)>>1;
+    for(Index pi=0; pi<size; ++pi)
+    {
+      Index i = IsLower ? pi : size-pi-1;
+      Index r = size - pi - 1;
+      if (!(Mode & UnitDiag))
+	rhs[i] /= cj(lhs[IsLower ? 0 : i]);
+      if (r>0)
+	Map<Matrix<RhsScalar,Dynamic,1> >(rhs+(IsLower? i+1 : 0),r) -=
+	    rhs[i] * ConjLhsType(LhsMap(lhs+(IsLower? 1 : 0),r));
+      IsLower ? lhs += size-pi : lhs -= r;
+    }
+  }
+};
+
+template<typename LhsScalar, typename RhsScalar, typename Index, int Mode, bool Conjugate, int StorageOrder>
+struct packed_triangular_solve_vector<LhsScalar, RhsScalar, Index, OnTheRight, Mode, Conjugate, StorageOrder>
+{
+  static void run(Index size, const LhsScalar* lhs, RhsScalar* rhs)
+  {
+    packed_triangular_solve_vector<LhsScalar,RhsScalar,Index,OnTheLeft,
+	((Mode&Upper)==Upper ? Lower : Upper) | (Mode&UnitDiag),
+	Conjugate,StorageOrder==RowMajor?ColMajor:RowMajor
+      >::run(size, lhs, rhs);
+  }
+};
+
+} // end namespace internal
+
+#endif // EIGEN_PACKED_TRIANGULAR_SOLVER_VECTOR_H

cs440-acg/ext/eigen/blas/README.txt

@@ -0,0 +1,6 @@
+
+This directory contains a BLAS library built on top of Eigen.
+
+This module is not built by default. In order to compile it, you need to
+type 'make blas' from within your build dir.
+

cs440-acg/ext/eigen/blas/Rank2Update.h

@@ -0,0 +1,57 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net>
+//
+// 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/.
+
+#ifndef EIGEN_RANK2UPDATE_H
+#define EIGEN_RANK2UPDATE_H
+
+namespace internal {
+
+/* Optimized selfadjoint matrix += alpha * uv' + conj(alpha)*vu'
+ * This is the low-level version of SelfadjointRank2Update.h
+ */
+template<typename Scalar, typename Index, int UpLo>
+struct rank2_update_selector
+{
+  static void run(Index size, Scalar* mat, Index stride, const Scalar* u, const Scalar* v, Scalar alpha)
+  {
+    typedef Map<const Matrix<Scalar,Dynamic,1> > OtherMap;
+    for (Index i=0; i<size; ++i)
+    {
+      Map<Matrix<Scalar,Dynamic,1> >(mat+stride*i+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1)) +=
+      numext::conj(alpha) * numext::conj(u[i]) * OtherMap(v+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1))
+                + alpha * numext::conj(v[i]) * OtherMap(u+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1));
+    }
+  }
+};
+
+/* Optimized selfadjoint matrix += alpha * uv' + conj(alpha)*vu'
+ * The matrix is in packed form.
+ */
+template<typename Scalar, typename Index, int UpLo>
+struct packed_rank2_update_selector
+{
+  static void run(Index size, Scalar* mat, const Scalar* u, const Scalar* v, Scalar alpha)
+  {
+    typedef Map<const Matrix<Scalar,Dynamic,1> > OtherMap;
+    Index offset = 0;
+    for (Index i=0; i<size; ++i)
+    {
+      Map<Matrix<Scalar,Dynamic,1> >(mat+offset, UpLo==Lower ? size-i : (i+1)) +=
+      numext::conj(alpha) * numext::conj(u[i]) * OtherMap(v+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1))
+                + alpha * numext::conj(v[i]) * OtherMap(u+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1));
+      //FIXME This should be handled outside.
+      mat[offset+(UpLo==Lower ? 0 : i)] = numext::real(mat[offset+(UpLo==Lower ? 0 : i)]);
+      offset += UpLo==Lower ? size-i : (i+1);
+    }
+  }
+};
+
+} // end namespace internal
+
+#endif // EIGEN_RANK2UPDATE_H

cs440-acg/ext/eigen/blas/common.h

@@ -0,0 +1,163 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#ifndef EIGEN_BLAS_COMMON_H
+#define EIGEN_BLAS_COMMON_H
+
+#include "../Eigen/Core"
+#include "../Eigen/Jacobi"
+
+#include <complex>
+
+#ifndef SCALAR
+#error the token SCALAR must be defined to compile this file
+#endif
+
+#include "../Eigen/src/misc/blas.h"
+
+#define NOTR    0
+#define TR      1
+#define ADJ     2
+
+#define LEFT    0
+#define RIGHT   1
+
+#define UP      0
+#define LO      1
+
+#define NUNIT   0
+#define UNIT    1
+
+#define INVALID 0xff
+
+#define OP(X)   (   ((X)=='N' || (X)=='n') ? NOTR   \
+                  : ((X)=='T' || (X)=='t') ? TR     \
+                  : ((X)=='C' || (X)=='c') ? ADJ    \
+                  : INVALID)
+
+#define SIDE(X) (   ((X)=='L' || (X)=='l') ? LEFT   \
+                  : ((X)=='R' || (X)=='r') ? RIGHT  \
+                  : INVALID)
+
+#define UPLO(X) (   ((X)=='U' || (X)=='u') ? UP     \
+                  : ((X)=='L' || (X)=='l') ? LO     \
+                  : INVALID)
+
+#define DIAG(X) (   ((X)=='N' || (X)=='n') ? NUNIT  \
+                  : ((X)=='U' || (X)=='u') ? UNIT   \
+                  : INVALID)
+
+
+inline bool check_op(const char* op)
+{
+  return OP(*op)!=0xff;
+}
+
+inline bool check_side(const char* side)
+{
+  return SIDE(*side)!=0xff;
+}
+
+inline bool check_uplo(const char* uplo)
+{
+  return UPLO(*uplo)!=0xff;
+}
+
+
+namespace Eigen {
+#include "BandTriangularSolver.h"
+#include "GeneralRank1Update.h"
+#include "PackedSelfadjointProduct.h"
+#include "PackedTriangularMatrixVector.h"
+#include "PackedTriangularSolverVector.h"
+#include "Rank2Update.h"
+}
+
+using namespace Eigen;
+
+typedef SCALAR Scalar;
+typedef NumTraits<Scalar>::Real RealScalar;
+typedef std::complex<RealScalar> Complex;
+
+enum
+{
+  IsComplex = Eigen::NumTraits<SCALAR>::IsComplex,
+  Conj = IsComplex
+};
+
+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;
+
+template<typename T>
+Map<Matrix<T,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> >
+matrix(T* data, int rows, int cols, int stride)
+{
+  return Map<Matrix<T,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> >(data, rows, cols, OuterStride<>(stride));
+}
+
+template<typename T>
+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<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;
+
+  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;
+}
+
+template<typename T>
+T* copy_back(T* x_cpy, T* x, int n, int incx)
+{
+  if(x_cpy==x)
+    return 0;
+
+  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;
+}
+
+#define EIGEN_BLAS_FUNC(X) EIGEN_CAT(SCALAR_SUFFIX,X##_)
+
+#endif // EIGEN_BLAS_COMMON_H

cs440-acg/ext/eigen/blas/complex_double.cpp

@@ -0,0 +1,20 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#define SCALAR        std::complex<double>
+#define SCALAR_SUFFIX z
+#define SCALAR_SUFFIX_UP "Z"
+#define REAL_SCALAR_SUFFIX d
+#define ISCOMPLEX     1
+
+#include "level1_impl.h"
+#include "level1_cplx_impl.h"
+#include "level2_impl.h"
+#include "level2_cplx_impl.h"
+#include "level3_impl.h"

cs440-acg/ext/eigen/blas/complex_single.cpp

@@ -0,0 +1,20 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#define SCALAR        std::complex<float>
+#define SCALAR_SUFFIX c
+#define SCALAR_SUFFIX_UP "C"
+#define REAL_SCALAR_SUFFIX s
+#define ISCOMPLEX     1
+
+#include "level1_impl.h"
+#include "level1_cplx_impl.h"
+#include "level2_impl.h"
+#include "level2_cplx_impl.h"
+#include "level3_impl.h"

cs440-acg/ext/eigen/blas/double.cpp

@@ -0,0 +1,32 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009 Gael Guennebaud <gael.guennebaud@inria.fr>
+// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net>
+//
+// 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/.
+
+#define SCALAR        double
+#define SCALAR_SUFFIX d
+#define SCALAR_SUFFIX_UP "D"
+#define ISCOMPLEX     0
+
+#include "level1_impl.h"
+#include "level1_real_impl.h"
+#include "level2_impl.h"
+#include "level2_real_impl.h"
+#include "level3_impl.h"
+
+double BLASFUNC(dsdot)(int* n, float* x, int* incx, float* y, int* incy)
+{
+  if(*n<=0) return 0;
+
+  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;
+}

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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);
+}

cs440-acg/ext/eigen/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

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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);
+}

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/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_ */
+

cs440-acg/ext/eigen/blas/fortran/complexdots.f

@@ -0,0 +1,43 @@
+      COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY)
+      INTEGER INCX,INCY,N
+      COMPLEX CX(*),CY(*)
+      COMPLEX RES
+      EXTERNAL CDOTCW
+      
+      CALL CDOTCW(N,CX,INCX,CY,INCY,RES)
+      CDOTC = RES
+      RETURN
+      END
+      
+      COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY)
+      INTEGER INCX,INCY,N
+      COMPLEX CX(*),CY(*)
+      COMPLEX RES
+      EXTERNAL CDOTUW
+      
+      CALL CDOTUW(N,CX,INCX,CY,INCY,RES)
+      CDOTU = RES
+      RETURN
+      END
+      
+      DOUBLE COMPLEX FUNCTION ZDOTC(N,CX,INCX,CY,INCY)
+      INTEGER INCX,INCY,N
+      DOUBLE COMPLEX CX(*),CY(*)
+      DOUBLE COMPLEX RES
+      EXTERNAL ZDOTCW
+      
+      CALL ZDOTCW(N,CX,INCX,CY,INCY,RES)
+      ZDOTC = RES
+      RETURN
+      END
+      
+      DOUBLE COMPLEX FUNCTION ZDOTU(N,CX,INCX,CY,INCY)
+      INTEGER INCX,INCY,N
+      DOUBLE COMPLEX CX(*),CY(*)
+      DOUBLE COMPLEX RES
+      EXTERNAL ZDOTUW
+      
+      CALL ZDOTUW(N,CX,INCX,CY,INCY,RES)
+      ZDOTU = RES
+      RETURN
+      END

cs440-acg/ext/eigen/blas/level1_cplx_impl.h

@@ -0,0 +1,133 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-2010 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#include "common.h"
+
+struct scalar_norm1_op {
+  typedef RealScalar result_type;
+  EIGEN_EMPTY_STRUCT_CTOR(scalar_norm1_op)
+  inline RealScalar operator() (const Scalar& a) const { return numext::norm1(a); }
+};
+namespace Eigen {
+  namespace internal {
+    template<> struct functor_traits<scalar_norm1_op >
+    {
+      enum { Cost = 3 * NumTraits<Scalar>::AddCost, PacketAccess = 0 };
+    };
+  }
+}
+
+// computes the sum of magnitudes of all vector elements or, for a complex vector x, the sum
+// res = |Rex1| + |Imx1| + |Rex2| + |Imx2| + ... + |Rexn| + |Imxn|, where x is a vector of order n
+RealScalar EIGEN_CAT(EIGEN_CAT(REAL_SCALAR_SUFFIX,SCALAR_SUFFIX),asum_)(int *n, RealScalar *px, int *incx)
+{
+//   std::cerr << "__asum " << *n << " " << *incx << "\n";
+  Complex* x = reinterpret_cast<Complex*>(px);
+
+  if(*n<=0) return 0;
+
+  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)
+  {
+    *res = Scalar(0);
+    return 0;
+  }
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+
+  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)
+{
+  Scalar* res = reinterpret_cast<Scalar*>(pres);
+
+  if(*n<=0)
+  {
+    *res = Scalar(0);
+    return 0;
+  }
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+
+  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;
+}
+
+RealScalar EIGEN_CAT(EIGEN_CAT(REAL_SCALAR_SUFFIX,SCALAR_SUFFIX),nrm2_)(int *n, RealScalar *px, int *incx)
+{
+//   std::cerr << "__nrm2 " << *n << " " << *incx << "\n";
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+
+  if(*incx==1)
+    return make_vector(x,*n).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)
+{
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+  RealScalar c = *pc;
+  RealScalar s = *ps;
+
+  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);
+
+  // TODO implement mixed real-scalar rotations
+       if(*incx<0 && *incy>0) internal::apply_rotation_in_the_plane(rvx, vy, JacobiRotation<Scalar>(c,s));
+  else if(*incx>0 && *incy<0) internal::apply_rotation_in_the_plane(vx, rvy, JacobiRotation<Scalar>(c,s));
+  else                        internal::apply_rotation_in_the_plane(vx, vy,  JacobiRotation<Scalar>(c,s));
+
+  return 0;
+}
+
+int EIGEN_CAT(EIGEN_CAT(SCALAR_SUFFIX,REAL_SCALAR_SUFFIX),scal_)(int *n, RealScalar *palpha, RealScalar *px, int *incx)
+{
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  RealScalar alpha = *palpha;
+
+//   std::cerr << "__scal " << *n << " " << alpha << " " << *incx << "\n";
+
+  if(*incx==1)  make_vector(x,*n) *= alpha;
+  else          make_vector(x,*n,std::abs(*incx)) *= alpha;
+
+  return 0;
+}

cs440-acg/ext/eigen/blas/level1_impl.h

@@ -0,0 +1,166 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-2010 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#include "common.h"
+
+int EIGEN_BLAS_FUNC(axpy)(const int *n, const RealScalar *palpha, const RealScalar *px, const int *incx, RealScalar *py, const int *incy)
+{
+  const Scalar* x = reinterpret_cast<const Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+  Scalar alpha  = *reinterpret_cast<const Scalar*>(palpha);
+
+  if(*n<=0) return 0;
+
+  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;
+}
+
+int EIGEN_BLAS_FUNC(copy)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy)
+{
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+
+  // be carefull, *incx==0 is allowed !!
+  if(*incx==1 && *incy==1)
+    make_vector(y,*n) = make_vector(x,*n);
+  else
+  {
+    if(*incx<0) x = x - (*n-1)*(*incx);
+    if(*incy<0) y = y - (*n-1)*(*incy);
+    for(int i=0;i<*n;++i)
+    {
+      *y = *x;
+      x += *incx;
+      y += *incy;
+    }
+  }
+
+  return 0;
+}
+
+int EIGEN_CAT(EIGEN_CAT(i,SCALAR_SUFFIX),amax_)(int *n, RealScalar *px, int *incx)
+{
+  if(*n<=0) return 0;
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+
+  DenseIndex ret;
+  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)  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;
+  Scalar* s = reinterpret_cast<Scalar*>(ps);
+
+  #if !ISCOMPLEX
+  Scalar r,z;
+  Scalar aa = abs(a);
+  Scalar ab = abs(b);
+  if((aa+ab)==Scalar(0))
+  {
+    *c = 1;
+    *s = 0;
+    r = 0;
+    z = 0;
+  }
+  else
+  {
+    r = sqrt(a*a + b*b);
+    Scalar amax = aa>ab ? a : b;
+    r = amax>0 ? r : -r;
+    *c = a/r;
+    *s = b/r;
+    z = 1;
+    if (aa > ab) z = *s;
+    if (ab > aa && *c!=RealScalar(0))
+      z = Scalar(1)/ *c;
+  }
+  *pa = r;
+  *pb = z;
+  #else
+  Scalar alpha;
+  RealScalar norm,scale;
+  if(abs(a)==RealScalar(0))
+  {
+    *c = RealScalar(0);
+    *s = Scalar(1);
+    a = b;
+  }
+  else
+  {
+    scale = abs(a) + abs(b);
+    norm = scale*sqrt((numext::abs2(a/scale)) + (numext::abs2(b/scale)));
+    alpha = a/abs(a);
+    *c = abs(a)/norm;
+    *s = alpha*numext::conj(b)/norm;
+    a = alpha*norm;
+  }
+  #endif
+
+//   JacobiRotation<Scalar> r;
+//   r.makeGivens(a,b);
+//   *c = r.c();
+//   *s = r.s();
+
+  return 0;
+}
+
+int EIGEN_BLAS_FUNC(scal)(int *n, RealScalar *palpha, RealScalar *px, int *incx)
+{
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+
+  if(*incx==1)  make_vector(x,*n) *= alpha;
+  else          make_vector(x,*n,std::abs(*incx)) *= alpha;
+
+  return 0;
+}
+
+int EIGEN_BLAS_FUNC(swap)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy)
+{
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+
+  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;
+}

cs440-acg/ext/eigen/blas/level1_real_impl.h

@@ -0,0 +1,100 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-2010 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#include "common.h"
+
+// computes the sum of magnitudes of all vector elements or, for a complex vector x, the sum
+// res = |Rex1| + |Imx1| + |Rex2| + |Imx2| + ... + |Rexn| + |Imxn|, where x is a vector of order n
+RealScalar EIGEN_BLAS_FUNC(asum)(int *n, RealScalar *px, int *incx)
+{
+//   std::cerr << "_asum " << *n << " " << *incx << "\n";
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+
+  if(*n<=0) return 0;
+
+  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.
+Scalar EIGEN_BLAS_FUNC(dot)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy)
+{
+//   std::cerr << "_dot " << *n << " " << *incx << " " << *incy << "\n";
+
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+
+  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;
+}
+
+// computes the Euclidean norm of a vector.
+// FIXME
+Scalar EIGEN_BLAS_FUNC(nrm2)(int *n, RealScalar *px, int *incx)
+{
+//   std::cerr << "_nrm2 " << *n << " " << *incx << "\n";
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+
+  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)
+{
+//   std::cerr << "_rot " << *n << " " << *incx << " " << *incy << "\n";
+  if(*n<=0) return 0;
+
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+  Scalar c = *reinterpret_cast<Scalar*>(pc);
+  Scalar s = *reinterpret_cast<Scalar*>(ps);
+
+  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);
+
+       if(*incx<0 && *incy>0) internal::apply_rotation_in_the_plane(rvx, vy, JacobiRotation<Scalar>(c,s));
+  else if(*incx>0 && *incy<0) internal::apply_rotation_in_the_plane(vx, rvy, JacobiRotation<Scalar>(c,s));
+  else                        internal::apply_rotation_in_the_plane(vx, vy,  JacobiRotation<Scalar>(c,s));
+
+
+  return 0;
+}
+
+/*
+// performs rotation of points in the modified plane.
+int EIGEN_BLAS_FUNC(rotm)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *param)
+{
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+
+  // TODO
+
+  return 0;
+}
+
+// computes the modified parameters for a Givens rotation.
+int EIGEN_BLAS_FUNC(rotmg)(RealScalar *d1, RealScalar *d2, RealScalar *x1, RealScalar *x2, RealScalar *param)
+{
+  // TODO
+
+  return 0;
+}
+*/

cs440-acg/ext/eigen/blas/level2_cplx_impl.h

@@ -0,0 +1,360 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-2010 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#include "common.h"
+
+/**  ZHEMV  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.
+  */
+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*, 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),
+  };
+
+  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<const Scalar*>(palpha);
+  Scalar beta   = *reinterpret_cast<const Scalar*>(pbeta);
+
+  // check arguments
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)        info = 1;
+  else if(*n<0)                   info = 2;
+  else if(*lda<std::max(1,*n))    info = 5;
+  else if(*incx==0)               info = 7;
+  else if(*incy==0)               info = 10;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"HEMV ",&info,6);
+
+  if(*n==0)
+    return 1;
+
+  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)) make_vector(actual_y, *n).setZero();
+    else                make_vector(actual_y, *n) *= beta;
+  }
+
+  if(alpha!=Scalar(0))
+  {
+    int code = UPLO(*uplo);
+    if(code>=2 || func[code]==0)
+      return 0;
+
+    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);
+
+  return 1;
+}
+
+/**  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.
+  */
+// int EIGEN_BLAS_FUNC(hbmv)(char *uplo, int *n, int *k, RealScalar *alpha, RealScalar *a, int *lda,
+//                           RealScalar *x, int *incx, RealScalar *beta, RealScalar *y, int *incy)
+// {
+//   return 1;
+// }
+
+/**  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.
+  */
+// int EIGEN_BLAS_FUNC(hpmv)(char *uplo, int *n, RealScalar *alpha, RealScalar *ap, RealScalar *x, int *incx, RealScalar *beta, RealScalar *y, int *incy)
+// {
+//   return 1;
+// }
+
+/**  ZHPR    performs the hermitian rank 1 operation
+  *
+  *     A := alpha*x*conjg( x' ) + A,
+  *
+  *  where alpha is a real scalar, x is an n element vector and A is an
+  *  n by n hermitian matrix, supplied in packed form.
+  */
+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 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);
+  RealScalar alpha = *palpha;
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"HPR  ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x, *n, *incx);
+
+  int code = UPLO(*uplo);
+  if(code>=2 || func[code]==0)
+    return 0;
+
+  func[code](*n, ap, x_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+
+  return 1;
+}
+
+/**  ZHPR2  performs the hermitian rank 2 operation
+  *
+  *     A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
+  *
+  *  where alpha is a scalar, x and y are n element vectors and A is an
+  *  n by n hermitian matrix, supplied in packed form.
+  */
+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 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);
+  Scalar* ap = reinterpret_cast<Scalar*>(pap);
+  Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*incy==0)                                                   info = 7;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"HPR2 ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x, *n, *incx);
+  Scalar* y_cpy = get_compact_vector(y, *n, *incy);
+
+  int code = UPLO(*uplo);
+  if(code>=2 || func[code]==0)
+    return 0;
+
+  func[code](*n, ap, x_cpy, y_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+  if(y_cpy!=y)  delete[] y_cpy;
+
+  return 1;
+}
+
+/**  ZHER   performs the hermitian rank 1 operation
+  *
+  *     A := alpha*x*conjg( x' ) + A,
+  *
+  *  where alpha is a real scalar, x is an n element vector and A is an
+  *  n by n hermitian matrix.
+  */
+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 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);
+  RealScalar alpha = *reinterpret_cast<RealScalar*>(palpha);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*lda<std::max(1,*n))                                        info = 7;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"HER  ",&info,6);
+
+  if(alpha==RealScalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x, *n, *incx);
+
+  int code = UPLO(*uplo);
+  if(code>=2 || func[code]==0)
+    return 0;
+
+  func[code](*n, a, *lda, x_cpy, x_cpy, alpha);
+
+  matrix(a,*n,*n,*lda).diagonal().imag().setZero();
+
+  if(x_cpy!=x)  delete[] x_cpy;
+
+  return 1;
+}
+
+/**  ZHER2  performs the hermitian rank 2 operation
+  *
+  *     A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
+  *
+  *  where alpha is a scalar, x and y are n element vectors and A is an n
+  *  by n hermitian matrix.
+  */
+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 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);
+  Scalar* a = reinterpret_cast<Scalar*>(pa);
+  Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*incy==0)                                                   info = 7;
+  else if(*lda<std::max(1,*n))                                        info = 9;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"HER2 ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x, *n, *incx);
+  Scalar* y_cpy = get_compact_vector(y, *n, *incy);
+
+  int code = UPLO(*uplo);
+  if(code>=2 || func[code]==0)
+    return 0;
+
+  func[code](*n, a, *lda, x_cpy, y_cpy, alpha);
+
+  matrix(a,*n,*n,*lda).diagonal().imag().setZero();
+
+  if(x_cpy!=x)  delete[] x_cpy;
+  if(y_cpy!=y)  delete[] y_cpy;
+
+  return 1;
+}
+
+/**  ZGERU  performs the rank 1 operation
+  *
+  *     A := alpha*x*y' + A,
+  *
+  *  where alpha is a scalar, x is an m element vector, y is an n element
+  *  vector and A is an m by n matrix.
+  */
+int EIGEN_BLAS_FUNC(geru)(int *m, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pa, int *lda)
+{
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+  Scalar* a = reinterpret_cast<Scalar*>(pa);
+  Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+
+  int info = 0;
+       if(*m<0)                                                       info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*incy==0)                                                   info = 7;
+  else if(*lda<std::max(1,*m))                                        info = 9;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"GERU ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x,*m,*incx);
+  Scalar* y_cpy = get_compact_vector(y,*n,*incy);
+
+  internal::general_rank1_update<Scalar,int,ColMajor,false,false>::run(*m, *n, a, *lda, x_cpy, y_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+  if(y_cpy!=y)  delete[] y_cpy;
+
+  return 1;
+}
+
+/**  ZGERC  performs the rank 1 operation
+  *
+  *     A := alpha*x*conjg( y' ) + A,
+  *
+  *  where alpha is a scalar, x is an m element vector, y is an n element
+  *  vector and A is an m by n matrix.
+  */
+int EIGEN_BLAS_FUNC(gerc)(int *m, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pa, int *lda)
+{
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+  Scalar* a = reinterpret_cast<Scalar*>(pa);
+  Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+
+  int info = 0;
+       if(*m<0)                                                       info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*incy==0)                                                   info = 7;
+  else if(*lda<std::max(1,*m))                                        info = 9;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"GERC ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x,*m,*incx);
+  Scalar* y_cpy = get_compact_vector(y,*n,*incy);
+
+  internal::general_rank1_update<Scalar,int,ColMajor,false,Conj>::run(*m, *n, a, *lda, x_cpy, y_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+  if(y_cpy!=y)  delete[] y_cpy;
+
+  return 1;
+}

cs440-acg/ext/eigen/blas/level2_impl.h

@@ -0,0 +1,553 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-2010 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#include "common.h"
+
+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 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
+  };
+
+  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<const Scalar*>(palpha);
+  Scalar beta   = *reinterpret_cast<const Scalar*>(pbeta);
+
+  // check arguments
+  int info = 0;
+  if(OP(*opa)==INVALID)           info = 1;
+  else if(*m<0)                   info = 2;
+  else if(*n<0)                   info = 3;
+  else if(*lda<std::max(1,*m))    info = 6;
+  else if(*incb==0)               info = 8;
+  else if(*incc==0)               info = 11;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"GEMV ",&info,6);
+
+  if(*m==0 || *n==0 || (alpha==Scalar(0) && beta==Scalar(1)))
+    return 0;
+
+  int actual_m = *m;
+  int actual_n = *n;
+  int code = OP(*opa);
+  if(code!=NOTR)
+    std::swap(actual_m,actual_n);
+
+  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)) make_vector(actual_c, actual_m).setZero();
+    else                make_vector(actual_c, actual_m) *= beta;
+  }
+
+  if(code>=4 || func[code]==0)
+    return 0;
+
+  func[code](actual_m, actual_n, a, *lda, actual_b, 1, actual_c, 1, alpha);
+
+  if(actual_b!=b) delete[] actual_b;
+  if(actual_c!=c) delete[] copy_back(actual_c,c,actual_m,*incc);
+
+  return 1;
+}
+
+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 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
+  };
+
+  const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+  Scalar* b = reinterpret_cast<Scalar*>(pb);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(OP(*opa)==INVALID)                                          info = 2;
+  else if(DIAG(*diag)==INVALID)                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*lda<std::max(1,*n))                                        info = 6;
+  else if(*incb==0)                                                   info = 8;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"TRSV ",&info,6);
+
+  Scalar* actual_b = get_compact_vector(b,*n,*incb);
+
+  int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3);
+  func[code](*n, a, *lda, actual_b);
+
+  if(actual_b!=b) delete[] copy_back(actual_b,b,*n,*incb);
+
+  return 0;
+}
+
+
+
+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 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
+  };
+
+  const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+  Scalar* b = reinterpret_cast<Scalar*>(pb);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(OP(*opa)==INVALID)                                          info = 2;
+  else if(DIAG(*diag)==INVALID)                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*lda<std::max(1,*n))                                        info = 6;
+  else if(*incb==0)                                                   info = 8;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"TRMV ",&info,6);
+
+  if(*n==0)
+    return 1;
+
+  Scalar* actual_b = get_compact_vector(b,*n,*incb);
+  Matrix<Scalar,Dynamic,1> res(*n);
+  res.setZero();
+
+  int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3);
+  if(code>=16 || func[code]==0)
+    return 0;
+
+  func[code](*n, *n, a, *lda, actual_b, 1, res.data(), 1, Scalar(1));
+
+  copy_back(res.data(),b,*n,*incb);
+  if(actual_b!=b) delete[] actual_b;
+
+  return 1;
+}
+
+/**  GBMV  performs one of the matrix-vector operations
+  *
+  *     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
+  *
+  *  where alpha and beta are scalars, x and y are vectors and A is an
+  *  m by n band matrix, with kl sub-diagonals and ku super-diagonals.
+  */
+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)
+{
+  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<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;
+  else if(*n<0)                                                       info = 3;
+  else if(*kl<0)                                                      info = 4;
+  else if(*ku<0)                                                      info = 5;
+  else if(*lda<coeff_rows)                                            info = 8;
+  else if(*incx==0)                                                   info = 10;
+  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);
+
+  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)) make_vector(actual_y, actual_m).setZero();
+    else                make_vector(actual_y, actual_m) *= beta;
+  }
+
+  ConstMatrixType mat_coeffs(a,coeff_rows,*n,*lda);
+
+  int nb = std::min(*n,(*m)+(*ku));
+  for(int j=0; j<nb; ++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)
+      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() * make_vector(actual_x+start,len) ).value();
+    else
+      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;
+}
+
+#if 0
+/**  TBMV  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.
+  */
+int EIGEN_BLAS_FUNC(tbmv)(char *uplo, char *opa, char *diag, int *n, int *k, RealScalar *pa, int *lda, RealScalar *px, int *incx)
+{
+  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;
+  else if(DIAG(*diag)==INVALID)                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*k<0)                                                       info = 5;
+  else if(*lda<coeff_rows)                                            info = 7;
+  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)
+      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() * make_vector(actual_x+start,len) ).value();
+    else
+      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
+
+/**  DTBSV  solves one of the systems of equations
+  *
+  *     A*x = b,   or   A'*x = b,
+  *
+  *  where b and x are n element vectors and A is an n by n unit, or
+  *  non-unit, upper or lower triangular band matrix, with ( k + 1 )
+  *  diagonals.
+  *
+  *  No test for singularity or near-singularity is included in this
+  *  routine. Such tests must be performed before calling this routine.
+  */
+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 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;
+  else if(DIAG(*diag)==INVALID)                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*k<0)                                                       info = 5;
+  else if(*lda<coeff_rows)                                            info = 7;
+  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;
+}
+
+/**  DTPMV  performs one of the matrix-vector operations
+  *
+  *     x := A*x,   or   x := A'*x,
+  *
+  *  where x is an n element vector and  A is an n by n unit, or non-unit,
+  *  upper or lower triangular matrix, supplied in packed form.
+  */
+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 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);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(OP(*opa)==INVALID)                                          info = 2;
+  else if(DIAG(*diag)==INVALID)                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*incx==0)                                                   info = 7;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"TPMV ",&info,6);
+
+  if(*n==0)
+    return 1;
+
+  Scalar* actual_x = get_compact_vector(x,*n,*incx);
+  Matrix<Scalar,Dynamic,1> res(*n);
+  res.setZero();
+
+  int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3);
+  if(code>=16 || func[code]==0)
+    return 0;
+
+  func[code](*n, ap, actual_x, res.data(), Scalar(1));
+
+  copy_back(res.data(),x,*n,*incx);
+  if(actual_x!=x) delete[] actual_x;
+
+  return 1;
+}
+
+/**  DTPSV  solves one of the systems of equations
+  *
+  *     A*x = b,   or   A'*x = b,
+  *
+  *  where b and x are n element vectors and A is an n by n unit, or
+  *  non-unit, upper or lower triangular matrix, supplied in packed form.
+  *
+  *  No test for singularity or near-singularity is included in this
+  *  routine. Such tests must be performed before calling this routine.
+  */
+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 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);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(OP(*opa)==INVALID)                                          info = 2;
+  else if(DIAG(*diag)==INVALID)                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*incx==0)                                                   info = 7;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"TPSV ",&info,6);
+
+  Scalar* actual_x = get_compact_vector(x,*n,*incx);
+
+  int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3);
+  func[code](*n, ap, actual_x);
+
+  if(actual_x!=x) delete[] copy_back(actual_x,x,*n,*incx);
+
+  return 1;
+}

cs440-acg/ext/eigen/blas/level2_real_impl.h

@@ -0,0 +1,306 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-2010 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#include "common.h"
+
+// y = alpha*A*x + beta*y
+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*, 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),
+  };
+
+  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<const Scalar*>(palpha);
+  Scalar beta   = *reinterpret_cast<const Scalar*>(pbeta);
+
+  // check arguments
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)        info = 1;
+  else if(*n<0)                   info = 2;
+  else if(*lda<std::max(1,*n))    info = 5;
+  else if(*incx==0)               info = 7;
+  else if(*incy==0)               info = 10;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"SYMV ",&info,6);
+
+  if(*n==0)
+    return 0;
+
+  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)) 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, actual_y, alpha);
+
+  if(actual_x!=x) delete[] actual_x;
+  if(actual_y!=y) delete[] copy_back(actual_y,y,*n,*incy);
+
+  return 1;
+}
+
+// C := alpha*x*x' + C
+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, Scalar*, int, const Scalar*, const Scalar*, const Scalar&);
+  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),
+  };
+
+  const Scalar* x = reinterpret_cast<const Scalar*>(px);
+  Scalar* c = reinterpret_cast<Scalar*>(pc);
+  Scalar alpha = *reinterpret_cast<const Scalar*>(palpha);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*ldc<std::max(1,*n))                                        info = 7;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"SYR  ",&info,6);
+
+  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
+  const Scalar* x_cpy = get_compact_vector(x,*n,*incx);
+
+  int code = UPLO(*uplo);
+  if(code>=2 || func[code]==0)
+    return 0;
+
+  func[code](*n, c, *ldc, x_cpy, x_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+
+  return 1;
+}
+
+// C := alpha*x*y' + alpha*y*x' + C
+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, Scalar*, int, const Scalar*, const Scalar*, Scalar);
+  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),
+  };
+
+  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<const Scalar*>(palpha);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*incy==0)                                                   info = 7;
+  else if(*ldc<std::max(1,*n))                                        info = 9;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"SYR2 ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  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;
+
+  func[code](*n, c, *ldc, x_cpy, y_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+  if(y_cpy!=y)  delete[] y_cpy;
+
+//   int code = UPLO(*uplo);
+//   if(code>=2 || func[code]==0)
+//     return 0;
+
+//   func[code](*n, a, *inca, b, *incb, c, *ldc, alpha);
+  return 1;
+}
+
+/**  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.
+  */
+// int EIGEN_BLAS_FUNC(sbmv)( char *uplo, int *n, int *k, RealScalar *alpha, RealScalar *a, int *lda,
+//                            RealScalar *x, int *incx, RealScalar *beta, RealScalar *y, int *incy)
+// {
+//   return 1;
+// }
+
+
+/**  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.
+  *
+  */
+// int EIGEN_BLAS_FUNC(spmv)(char *uplo, int *n, RealScalar *alpha, RealScalar *ap, RealScalar *x, int *incx, RealScalar *beta, RealScalar *y, int *incy)
+// {
+//   return 1;
+// }
+
+/**  DSPR    performs the symmetric rank 1 operation
+  *
+  *     A := alpha*x*x' + A,
+  *
+  *  where alpha is a real scalar, x is an n element vector and A is an
+  *  n by n symmetric matrix, supplied in packed form.
+  */
+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 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);
+  Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"SPR  ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x, *n, *incx);
+
+  int code = UPLO(*uplo);
+  if(code>=2 || func[code]==0)
+    return 0;
+
+  func[code](*n, ap, x_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+
+  return 1;
+}
+
+/**  DSPR2  performs the symmetric rank 2 operation
+  *
+  *     A := alpha*x*y' + alpha*y*x' + A,
+  *
+  *  where alpha is a scalar, x and y are n element vectors and A is an
+  *  n by n symmetric matrix, supplied in packed form.
+  */
+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 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);
+  Scalar* ap = reinterpret_cast<Scalar*>(pap);
+  Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+
+  int info = 0;
+  if(UPLO(*uplo)==INVALID)                                            info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*incy==0)                                                   info = 7;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"SPR2 ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x, *n, *incx);
+  Scalar* y_cpy = get_compact_vector(y, *n, *incy);
+
+  int code = UPLO(*uplo);
+  if(code>=2 || func[code]==0)
+    return 0;
+
+  func[code](*n, ap, x_cpy, y_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+  if(y_cpy!=y)  delete[] y_cpy;
+
+  return 1;
+}
+
+/**  DGER   performs the rank 1 operation
+  *
+  *     A := alpha*x*y' + A,
+  *
+  *  where alpha is a scalar, x is an m element vector, y is an n element
+  *  vector and A is an m by n matrix.
+  */
+int EIGEN_BLAS_FUNC(ger)(int *m, int *n, Scalar *palpha, Scalar *px, int *incx, Scalar *py, int *incy, Scalar *pa, int *lda)
+{
+  Scalar* x = reinterpret_cast<Scalar*>(px);
+  Scalar* y = reinterpret_cast<Scalar*>(py);
+  Scalar* a = reinterpret_cast<Scalar*>(pa);
+  Scalar alpha = *reinterpret_cast<Scalar*>(palpha);
+
+  int info = 0;
+       if(*m<0)                                                       info = 1;
+  else if(*n<0)                                                       info = 2;
+  else if(*incx==0)                                                   info = 5;
+  else if(*incy==0)                                                   info = 7;
+  else if(*lda<std::max(1,*m))                                        info = 9;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"GER  ",&info,6);
+
+  if(alpha==Scalar(0))
+    return 1;
+
+  Scalar* x_cpy = get_compact_vector(x,*m,*incx);
+  Scalar* y_cpy = get_compact_vector(y,*n,*incy);
+
+  internal::general_rank1_update<Scalar,int,ColMajor,false,false>::run(*m, *n, a, *lda, x_cpy, y_cpy, alpha);
+
+  if(x_cpy!=x)  delete[] x_cpy;
+  if(y_cpy!=y)  delete[] y_cpy;
+
+  return 1;
+}

cs440-acg/ext/eigen/blas/level3_impl.h

@@ -0,0 +1,702 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009-2010 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+#include <iostream>
+#include "common.h"
+
+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, DenseIndex, Scalar, internal::level3_blocking<Scalar,Scalar>&, Eigen::internal::GemmParallelInfo<DenseIndex>*);
+  static const functype func[12] = {
+    // array index: NOTR  | (NOTR << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,ColMajor,false,ColMajor,1>::run),
+    // array index: TR    | (NOTR << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,false,ColMajor,1>::run),
+    // array index: ADJ   | (NOTR << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,1>::run),
+    0,
+    // array index: NOTR  | (TR   << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,false,ColMajor,1>::run),
+    // array index: TR    | (TR   << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,RowMajor,false,ColMajor,1>::run),
+    // array index: ADJ   | (TR   << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,RowMajor,false,ColMajor,1>::run),
+    0,
+    // array index: NOTR  | (ADJ  << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor,1>::run),
+    // array index: TR    | (ADJ  << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,RowMajor,Conj, ColMajor,1>::run),
+    // array index: ADJ   | (ADJ  << 2)
+    (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,RowMajor,Conj, ColMajor,1>::run),
+    0
+  };
+
+  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<const Scalar*>(palpha);
+  Scalar beta   = *reinterpret_cast<const Scalar*>(pbeta);
+
+  int info = 0;
+  if(OP(*opa)==INVALID)                                               info = 1;
+  else if(OP(*opb)==INVALID)                                          info = 2;
+  else if(*m<0)                                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*k<0)                                                       info = 5;
+  else if(*lda<std::max(1,(OP(*opa)==NOTR)?*m:*k))                    info = 8;
+  else if(*ldb<std::max(1,(OP(*opb)==NOTR)?*k:*n))                    info = 10;
+  else if(*ldc<std::max(1,*m))                                        info = 13;
+  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;
+  }
+
+  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, 1, *ldc, alpha, blocking, 0);
+  return 0;
+}
+
+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, DenseIndex, internal::level3_blocking<Scalar,Scalar>&);
+  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,1>::run),
+    // array index: TR    | (LEFT  << 2) | (UP << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0,          false,RowMajor,ColMajor,1>::run),
+    // array index: ADJ   | (LEFT  << 2) | (UP << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0,          Conj, RowMajor,ColMajor,1>::run),\
+    0,
+    // array index: NOTR  | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0,          false,ColMajor,ColMajor,1>::run),
+    // array index: TR    | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0,          false,RowMajor,ColMajor,1>::run),
+    // array index: ADJ   | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0,          Conj, RowMajor,ColMajor,1>::run),
+    0,
+    // array index: NOTR  | (LEFT  << 2) | (LO << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0,          false,ColMajor,ColMajor,1>::run),
+    // array index: TR    | (LEFT  << 2) | (LO << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0,          false,RowMajor,ColMajor,1>::run),
+    // array index: ADJ   | (LEFT  << 2) | (LO << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0,          Conj, RowMajor,ColMajor,1>::run),
+    0,
+    // array index: NOTR  | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0,          false,ColMajor,ColMajor,1>::run),
+    // array index: TR    | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0,          false,RowMajor,ColMajor,1>::run),
+    // array index: ADJ   | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0,          Conj, RowMajor,ColMajor,1>::run),
+    0,
+    // array index: NOTR  | (LEFT  << 2) | (UP << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,false,ColMajor,ColMajor,1>::run),
+    // array index: TR    | (LEFT  << 2) | (UP << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,false,RowMajor,ColMajor,1>::run),
+    // array index: ADJ   | (LEFT  << 2) | (UP << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,Conj, RowMajor,ColMajor,1>::run),
+    0,
+    // array index: NOTR  | (RIGHT << 2) | (UP << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,false,ColMajor,ColMajor,1>::run),
+    // array index: TR    | (RIGHT << 2) | (UP << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,false,RowMajor,ColMajor,1>::run),
+    // array index: ADJ   | (RIGHT << 2) | (UP << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,Conj, RowMajor,ColMajor,1>::run),
+    0,
+    // array index: NOTR  | (LEFT  << 2) | (LO << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,false,ColMajor,ColMajor,1>::run),
+    // array index: TR    | (LEFT  << 2) | (LO << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,false,RowMajor,ColMajor,1>::run),
+    // array index: ADJ   | (LEFT  << 2) | (LO << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,Conj, RowMajor,ColMajor,1>::run),
+    0,
+    // array index: NOTR  | (RIGHT << 2) | (LO << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,false,ColMajor,ColMajor,1>::run),
+    // array index: TR    | (RIGHT << 2) | (LO << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,false,RowMajor,ColMajor,1>::run),
+    // array index: ADJ   | (RIGHT << 2) | (LO << 3) | (UNIT  << 4)
+    (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,Conj, RowMajor,ColMajor,1>::run),
+    0
+  };
+
+  const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+  Scalar* b = reinterpret_cast<Scalar*>(pb);
+  Scalar  alpha = *reinterpret_cast<const Scalar*>(palpha);
+
+  int info = 0;
+  if(SIDE(*side)==INVALID)                                            info = 1;
+  else if(UPLO(*uplo)==INVALID)                                       info = 2;
+  else if(OP(*opa)==INVALID)                                          info = 3;
+  else if(DIAG(*diag)==INVALID)                                       info = 4;
+  else if(*m<0)                                                       info = 5;
+  else if(*n<0)                                                       info = 6;
+  else if(*lda<std::max(1,(SIDE(*side)==LEFT)?*m:*n))                 info = 9;
+  else if(*ldb<std::max(1,*m))                                        info = 11;
+  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,1,false);
+    func[code](*m, *n, a, *lda, b, 1, *ldb, blocking);
+  }
+  else
+  {
+    internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*n,1,false);
+    func[code](*n, *m, a, *lda, b, 1, *ldb, blocking);
+  }
+
+  if(alpha!=Scalar(1))
+    matrix(b,*m,*n,*ldb) *= alpha;
+
+  return 0;
+}
+
+
+// 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)(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, DenseIndex, const Scalar&, internal::level3_blocking<Scalar,Scalar>&);
+  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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::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,1>::run),
+    0
+  };
+
+  const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+  Scalar* b = reinterpret_cast<Scalar*>(pb);
+  Scalar  alpha = *reinterpret_cast<const Scalar*>(palpha);
+
+  int info = 0;
+  if(SIDE(*side)==INVALID)                                            info = 1;
+  else if(UPLO(*uplo)==INVALID)                                       info = 2;
+  else if(OP(*opa)==INVALID)                                          info = 3;
+  else if(DIAG(*diag)==INVALID)                                       info = 4;
+  else if(*m<0)                                                       info = 5;
+  else if(*n<0)                                                       info = 6;
+  else if(*lda<std::max(1,(SIDE(*side)==LEFT)?*m:*n))                 info = 9;
+  else if(*ldb<std::max(1,*m))                                        info = 11;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"TRMM ",&info,6);
+
+  int code = OP(*opa) | (SIDE(*side) << 2) | (UPLO(*uplo) << 3) | (DIAG(*diag) << 4);
+
+  if(*m==0 || *n==0)
+    return 1;
+
+  // FIXME find a way to avoid this copy
+  Matrix<Scalar,Dynamic,Dynamic,ColMajor> tmp = matrix(b,*m,*n,*ldb);
+  matrix(b,*m,*n,*ldb).setZero();
+
+  if(SIDE(*side)==LEFT)
+  {
+    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, 1, *ldb, alpha, blocking);
+  }
+  else
+  {
+    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, 1, *ldb, alpha, blocking);
+  }
+  return 1;
+}
+
+// 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)(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";
+  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<const Scalar*>(palpha);
+  Scalar beta  = *reinterpret_cast<const Scalar*>(pbeta);
+
+  int info = 0;
+  if(SIDE(*side)==INVALID)                                            info = 1;
+  else if(UPLO(*uplo)==INVALID)                                       info = 2;
+  else if(*m<0)                                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*lda<std::max(1,(SIDE(*side)==LEFT)?*m:*n))                 info = 7;
+  else if(*ldb<std::max(1,*m))                                        info = 9;
+  else if(*ldc<std::max(1,*m))                                        info = 12;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"SYMM ",&info,6);
+
+  if(beta!=Scalar(1))
+  {
+    if(beta==Scalar(0)) matrix(c, *m, *n, *ldc).setZero();
+    else                matrix(c, *m, *n, *ldc) *= beta;
+  }
+
+  if(*m==0 || *n==0)
+  {
+    return 1;
+  }
+
+  int size = (SIDE(*side)==LEFT) ? (*m) : (*n);
+  #if ISCOMPLEX
+  // FIXME add support for symmetric complex matrix
+  Matrix<Scalar,Dynamic,Dynamic,ColMajor> matA(size,size);
+  if(UPLO(*uplo)==UP)
+  {
+    matA.triangularView<Upper>() = matrix(a,size,size,*lda);
+    matA.triangularView<Lower>() = matrix(a,size,size,*lda).transpose();
+  }
+  else if(UPLO(*uplo)==LO)
+  {
+    matA.triangularView<Lower>() = matrix(a,size,size,*lda);
+    matA.triangularView<Upper>() = matrix(a,size,size,*lda).transpose();
+  }
+  if(SIDE(*side)==LEFT)
+    matrix(c, *m, *n, *ldc) += alpha * matA * matrix(b, *m, *n, *ldb);
+  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,1>::run(*m, *n, a, *lda, b, *ldb, c, 1, *ldc, alpha, blocking);
+    else if(UPLO(*uplo)==LO)  internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,true,false, ColMajor,false,false, ColMajor,1>::run(*m, *n, a, *lda, b, *ldb, c, 1, *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,1>::run(*m, *n, b, *ldb, a, *lda, c, 1, *ldc, alpha, blocking);
+    else if(UPLO(*uplo)==LO)  internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,false,false, ColMajor,true,false, ColMajor,1>::run(*m, *n, b, *ldb, a, *lda, c, 1, *ldc, alpha, blocking);
+    else                      return 0;
+  else
+    return 0;
+  #endif
+
+  return 0;
+}
+
+// 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)(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, 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, 1, Upper>::run),
+    // array index: TR    | (UP << 2)
+    (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,ColMajor,Conj, 1, Upper>::run),
+    // array index: ADJ   | (UP << 2)
+    (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,ColMajor,false,1, Upper>::run),
+    0,
+    // array index: NOTR  | (LO << 2)
+    (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,ColMajor,Conj, 1, Lower>::run),
+    // array index: TR    | (LO << 2)
+    (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,ColMajor,Conj, 1, Lower>::run),
+    // array index: ADJ   | (LO << 2)
+    (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,ColMajor,false,1, Lower>::run),
+    0
+  };
+  #endif
+
+  const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+  Scalar* c = reinterpret_cast<Scalar*>(pc);
+  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 || (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;
+  else if(*ldc<std::max(1,*n))                                        info = 10;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"SYRK ",&info,6);
+
+  if(beta!=Scalar(1))
+  {
+    if(UPLO(*uplo)==UP)
+      if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Upper>().setZero();
+      else                matrix(c, *n, *n, *ldc).triangularView<Upper>() *= beta;
+    else
+      if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Lower>().setZero();
+      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)
+  {
+    if(OP(*op)==NOTR)
+      matrix(c, *n, *n, *ldc).triangularView<Upper>() += alpha * matrix(a,*n,*k,*lda) * matrix(a,*n,*k,*lda).transpose();
+    else
+      matrix(c, *n, *n, *ldc).triangularView<Upper>() += alpha * matrix(a,*k,*n,*lda).transpose() * matrix(a,*k,*n,*lda);
+  }
+  else
+  {
+    if(OP(*op)==NOTR)
+      matrix(c, *n, *n, *ldc).triangularView<Lower>() += alpha * matrix(a,*n,*k,*lda) * matrix(a,*n,*k,*lda).transpose();
+    else
+      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, 1, *ldc, alpha, blocking);
+  #endif
+
+  return 0;
+}
+
+// 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)(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)
+{
+  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<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 || (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;
+  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"SYR2K",&info,6);
+
+  if(beta!=Scalar(1))
+  {
+    if(UPLO(*uplo)==UP)
+      if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Upper>().setZero();
+      else                matrix(c, *n, *n, *ldc).triangularView<Upper>() *= beta;
+    else
+      if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Lower>().setZero();
+      else                matrix(c, *n, *n, *ldc).triangularView<Lower>() *= beta;
+  }
+
+  if(*k==0)
+    return 1;
+
+  if(OP(*op)==NOTR)
+  {
+    if(UPLO(*uplo)==UP)
+    {
+      matrix(c, *n, *n, *ldc).triangularView<Upper>()
+        += alpha *matrix(a, *n, *k, *lda)*matrix(b, *n, *k, *ldb).transpose()
+        +  alpha*matrix(b, *n, *k, *ldb)*matrix(a, *n, *k, *lda).transpose();
+    }
+    else if(UPLO(*uplo)==LO)
+      matrix(c, *n, *n, *ldc).triangularView<Lower>()
+        += alpha*matrix(a, *n, *k, *lda)*matrix(b, *n, *k, *ldb).transpose()
+        +  alpha*matrix(b, *n, *k, *ldb)*matrix(a, *n, *k, *lda).transpose();
+  }
+  else if(OP(*op)==TR || OP(*op)==ADJ)
+  {
+    if(UPLO(*uplo)==UP)
+      matrix(c, *n, *n, *ldc).triangularView<Upper>()
+        += alpha*matrix(a, *k, *n, *lda).transpose()*matrix(b, *k, *n, *ldb)
+        +  alpha*matrix(b, *k, *n, *ldb).transpose()*matrix(a, *k, *n, *lda);
+    else if(UPLO(*uplo)==LO)
+      matrix(c, *n, *n, *ldc).triangularView<Lower>()
+        += alpha*matrix(a, *k, *n, *lda).transpose()*matrix(b, *k, *n, *ldb)
+        +  alpha*matrix(b, *k, *n, *ldb).transpose()*matrix(a, *k, *n, *lda);
+  }
+
+  return 0;
+}
+
+
+#if ISCOMPLEX
+
+// 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)(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)
+{
+  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<const Scalar*>(palpha);
+  Scalar beta  = *reinterpret_cast<const Scalar*>(pbeta);
+
+//   std::cerr << "in hemm " << *side << " " << *uplo << " " << *m << " " << *n << " " << alpha << " " << *lda << " " << beta << " " << *ldc << "\n";
+
+  int info = 0;
+  if(SIDE(*side)==INVALID)                                            info = 1;
+  else if(UPLO(*uplo)==INVALID)                                       info = 2;
+  else if(*m<0)                                                       info = 3;
+  else if(*n<0)                                                       info = 4;
+  else if(*lda<std::max(1,(SIDE(*side)==LEFT)?*m:*n))                 info = 7;
+  else if(*ldb<std::max(1,*m))                                        info = 9;
+  else if(*ldc<std::max(1,*m))                                        info = 12;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"HEMM ",&info,6);
+
+  if(beta==Scalar(0))       matrix(c, *m, *n, *ldc).setZero();
+  else if(beta!=Scalar(1))  matrix(c, *m, *n, *ldc) *= beta;
+
+  if(*m==0 || *n==0)
+  {
+    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, 1>
+                                ::run(*m, *n, a, *lda, b, *ldb, c, 1, *ldc, alpha, blocking);
+    else if(UPLO(*uplo)==LO)  internal::product_selfadjoint_matrix<Scalar,DenseIndex,ColMajor,true,false, ColMajor,false,false, ColMajor,1>
+                                ::run(*m, *n, a, *lda, b, *ldb, c, 1, *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, 1>
+                                ::run(*m, *n, b, *ldb, a, *lda, c, 1, *ldc, alpha, blocking);*/
+    else if(UPLO(*uplo)==LO)  internal::product_selfadjoint_matrix<Scalar,DenseIndex,ColMajor,false,false, ColMajor,true,false, ColMajor,1>
+                                ::run(*m, *n, b, *ldb, a, *lda, c, 1, *ldc, alpha, blocking);
+    else                      return 0;
+  }
+  else
+  {
+    return 0;
+  }
+
+  return 0;
+}
+
+// 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)(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 herk " << *uplo << " " << *op << " " << *n << " " << *k << " " << *palpha << " " << *lda << " " << *pbeta << " " << *ldc << "\n";
+
+  typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, 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,1,Upper>::run),
+    0,
+    // array index: ADJ   | (UP << 2)
+    (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,1,Upper>::run),
+    0,
+    // array index: NOTR  | (LO << 2)
+    (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor,1,Lower>::run),
+    0,
+    // array index: ADJ   | (LO << 2)
+    (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,1,Lower>::run),
+    0
+  };
+
+  const Scalar* a = reinterpret_cast<const Scalar*>(pa);
+  Scalar* c = reinterpret_cast<Scalar*>(pc);
+  RealScalar alpha = *palpha;
+  RealScalar beta  = *pbeta;
+
+//   std::cerr << "in herk " << *uplo << " " << *op << " " << *n << " " << *k << " " << alpha << " " << *lda << " " << 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(*ldc<std::max(1,*n))                                        info = 10;
+  if(info)
+    return xerbla_(SCALAR_SUFFIX_UP"HERK ",&info,6);
+
+  int code = OP(*op) | (UPLO(*uplo) << 2);
+
+  if(beta!=RealScalar(1))
+  {
+    if(UPLO(*uplo)==UP)
+      if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Upper>().setZero();
+      else                matrix(c, *n, *n, *ldc).triangularView<StrictlyUpper>() *= beta;
+    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;
+      matrix(c, *n, *n, *ldc).diagonal().imag().setZero();
+    }
+  }
+
+  if(*k>0 && alpha!=RealScalar(0))
+  {
+    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, 1, *ldc, alpha, blocking);
+    matrix(c, *n, *n, *ldc).diagonal().imag().setZero();
+  }
+  return 0;
+}
+
+// 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)(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)
+{
+  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<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(*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);
+
+  if(beta!=RealScalar(1))
+  {
+    if(UPLO(*uplo)==UP)
+      if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Upper>().setZero();
+      else                matrix(c, *n, *n, *ldc).triangularView<StrictlyUpper>() *= beta;
+    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;
+      matrix(c, *n, *n, *ldc).diagonal().imag().setZero();
+    }
+  }
+  else if(*k>0 && alpha!=Scalar(0))
+    matrix(c, *n, *n, *ldc).diagonal().imag().setZero();
+
+  if(*k==0)
+    return 1;
+
+  if(OP(*op)==NOTR)
+  {
+    if(UPLO(*uplo)==UP)
+    {
+      matrix(c, *n, *n, *ldc).triangularView<Upper>()
+        +=            alpha *matrix(a, *n, *k, *lda)*matrix(b, *n, *k, *ldb).adjoint()
+        +  numext::conj(alpha)*matrix(b, *n, *k, *ldb)*matrix(a, *n, *k, *lda).adjoint();
+    }
+    else if(UPLO(*uplo)==LO)
+      matrix(c, *n, *n, *ldc).triangularView<Lower>()
+        += alpha*matrix(a, *n, *k, *lda)*matrix(b, *n, *k, *ldb).adjoint()
+        +  numext::conj(alpha)*matrix(b, *n, *k, *ldb)*matrix(a, *n, *k, *lda).adjoint();
+  }
+  else if(OP(*op)==ADJ)
+  {
+    if(UPLO(*uplo)==UP)
+      matrix(c, *n, *n, *ldc).triangularView<Upper>()
+        +=             alpha*matrix(a, *k, *n, *lda).adjoint()*matrix(b, *k, *n, *ldb)
+        +  numext::conj(alpha)*matrix(b, *k, *n, *ldb).adjoint()*matrix(a, *k, *n, *lda);
+    else if(UPLO(*uplo)==LO)
+      matrix(c, *n, *n, *ldc).triangularView<Lower>()
+        +=             alpha*matrix(a, *k, *n, *lda).adjoint()*matrix(b, *k, *n, *ldb)
+        +  numext::conj(alpha)*matrix(b, *k, *n, *ldb).adjoint()*matrix(a, *k, *n, *lda);
+  }
+
+  return 1;
+}
+
+#endif // ISCOMPLEX

cs440-acg/ext/eigen/blas/single.cpp

@@ -0,0 +1,22 @@
+// This file is part of Eigen, a lightweight C++ template library
+// for linear algebra.
+//
+// Copyright (C) 2009 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
+// with this file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+#define SCALAR        float
+#define SCALAR_SUFFIX s
+#define SCALAR_SUFFIX_UP "S"
+#define ISCOMPLEX     0
+
+#include "level1_impl.h"
+#include "level1_real_impl.h"
+#include "level2_impl.h"
+#include "level2_real_impl.h"
+#include "level3_impl.h"
+
+float BLASFUNC(sdsdot)(int* n, float* alpha, float* x, int* incx, float* y, int* incy)
+{ return double(*alpha) + BLASFUNC(dsdot)(n, x, incx, y, incy); }

cs440-acg/ext/eigen/blas/testing/CMakeLists.txt

@@ -0,0 +1,40 @@
+
+macro(ei_add_blas_test testname)
+
+  set(targetname ${testname})
+
+  set(filename ${testname}.f)
+  add_executable(${targetname} ${filename})
+
+  target_link_libraries(${targetname} eigen_blas)
+
+  if(EIGEN_STANDARD_LIBRARIES_TO_LINK_TO)
+    target_link_libraries(${targetname} ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO})
+  endif()
+
+  target_link_libraries(${targetname} ${EXTERNAL_LIBS})
+
+  add_test(${testname} "${Eigen_SOURCE_DIR}/blas/testing/runblastest.sh" "${testname}" "${Eigen_SOURCE_DIR}/blas/testing/${testname}.dat")
+  add_dependencies(buildtests ${targetname})
+  
+endmacro(ei_add_blas_test)
+
+ei_add_blas_test(sblat1)
+ei_add_blas_test(sblat2)
+ei_add_blas_test(sblat3)
+
+ei_add_blas_test(dblat1)
+ei_add_blas_test(dblat2)
+ei_add_blas_test(dblat3)
+
+ei_add_blas_test(cblat1)
+ei_add_blas_test(cblat2)
+ei_add_blas_test(cblat3)
+
+ei_add_blas_test(zblat1)
+ei_add_blas_test(zblat2)
+ei_add_blas_test(zblat3)
+
+# add_custom_target(level1)
+# add_dependencies(level1 sblat1)
+

cs440-acg/ext/eigen/blas/testing/cblat1.f

@@ -0,0 +1,724 @@
+*> \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
+*
+*  -- 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)
+*     .. Scalars in Common ..
+      INTEGER          ICASE, INCX, INCY, MODE, N
+      LOGICAL          PASS
+*     .. Local Scalars ..
+      REAL             SFAC
+      INTEGER          IC
+*     .. External Subroutines ..
+      EXTERNAL         CHECK1, CHECK2, HEADER
+*     .. Common blocks ..
+      COMMON           /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Data statements ..
+      DATA             SFAC/9.765625E-4/
+*     .. Executable Statements ..
+      WRITE (NOUT,99999)
+      DO 20 IC = 1, 10
+         ICASE = IC
+         CALL HEADER
+*
+*        Initialize PASS, INCX, INCY, and MODE for a new case.
+*        The value 9999 for INCX, INCY or MODE will appear in the
+*        detailed  output, if any, for cases that do not involve
+*        these parameters.
+*
+         PASS = .TRUE.
+         INCX = 9999
+         INCY = 9999
+         MODE = 9999
+         IF (ICASE.LE.5) THEN
+            CALL CHECK2(SFAC)
+         ELSE IF (ICASE.GE.6) THEN
+            CALL CHECK1(SFAC)
+         END IF
+*        -- Print
+         IF (PASS) WRITE (NOUT,99998)
+   20 CONTINUE
+      STOP
+*
+99999 FORMAT (' Complex BLAS Test Program Results',/1X)
+99998 FORMAT ('                                    ----- PASS -----')
+      END
+      SUBROUTINE HEADER
+*     .. Parameters ..
+      INTEGER          NOUT
+      PARAMETER        (NOUT=6)
+*     .. Scalars in Common ..
+      INTEGER          ICASE, INCX, INCY, MODE, N
+      LOGICAL          PASS
+*     .. Local Arrays ..
+      CHARACTER*6      L(10)
+*     .. Common blocks ..
+      COMMON           /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Data statements ..
+      DATA             L(1)/'CDOTC '/
+      DATA             L(2)/'CDOTU '/
+      DATA             L(3)/'CAXPY '/
+      DATA             L(4)/'CCOPY '/
+      DATA             L(5)/'CSWAP '/
+      DATA             L(6)/'SCNRM2'/
+      DATA             L(7)/'SCASUM'/
+      DATA             L(8)/'CSCAL '/
+      DATA             L(9)/'CSSCAL'/
+      DATA             L(10)/'ICAMAX'/
+*     .. Executable Statements ..
+      WRITE (NOUT,99999) ICASE, L(ICASE)
+      RETURN
+*
+99999 FORMAT (/' Test of subprogram number',I3,12X,A6)
+      END
+      SUBROUTINE CHECK1(SFAC)
+*     .. Parameters ..
+      INTEGER           NOUT
+      PARAMETER         (NOUT=6)
+*     .. Scalar Arguments ..
+      REAL              SFAC
+*     .. Scalars in Common ..
+      INTEGER           ICASE, INCX, INCY, MODE, N
+      LOGICAL           PASS
+*     .. Local Scalars ..
+      COMPLEX           CA
+      REAL              SA
+      INTEGER           I, J, LEN, NP1
+*     .. Local Arrays ..
+      COMPLEX           CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8),
+     +                  MWPCS(5), MWPCT(5)
+      REAL              STRUE2(5), STRUE4(5)
+      INTEGER           ITRUE3(5)
+*     .. External Functions ..
+      REAL              SCASUM, SCNRM2
+      INTEGER           ICAMAX
+      EXTERNAL          SCASUM, SCNRM2, ICAMAX
+*     .. External Subroutines ..
+      EXTERNAL          CSCAL, CSSCAL, CTEST, ITEST1, STEST1
+*     .. Intrinsic Functions ..
+      INTRINSIC         MAX
+*     .. Common blocks ..
+      COMMON            /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Data statements ..
+      DATA              SA, CA/0.3E0, (0.4E0,-0.7E0)/
+      DATA              ((CV(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),
+     +                  (1.0E0,2.0E0), (0.3E0,-0.4E0), (3.0E0,4.0E0),
+     +                  (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
+     +                  (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
+     +                  (0.1E0,-0.3E0), (0.5E0,-0.1E0), (5.0E0,6.0E0),
+     +                  (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
+     +                  (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.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),
+     +                  (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
+     +                  (4.0E0,5.0E0), (0.3E0,-0.4E0), (6.0E0,7.0E0),
+     +                  (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
+     +                  (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
+     +                  (0.1E0,-0.3E0), (8.0E0,9.0E0), (0.5E0,-0.1E0),
+     +                  (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
+     +                  (2.0E0,5.0E0), (2.0E0,5.0E0), (0.1E0,0.1E0),
+     +                  (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.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),
+     +                  (1.0E0,2.0E0), (-0.16E0,-0.37E0), (3.0E0,4.0E0),
+     +                  (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
+     +                  (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
+     +                  (-0.17E0,-0.19E0), (0.13E0,-0.39E0),
+     +                  (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
+     +                  (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
+     +                  (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.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),
+     +                  (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
+     +                  (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
+     +                  (4.0E0,5.0E0), (-0.16E0,-0.37E0), (6.0E0,7.0E0),
+     +                  (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
+     +                  (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
+     +                  (-0.17E0,-0.19E0), (8.0E0,9.0E0),
+     +                  (0.13E0,-0.39E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
+     +                  (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
+     +                  (0.11E0,-0.03E0), (3.0E0,6.0E0),
+     +                  (-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.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),
+     +                  (1.0E0,2.0E0), (0.09E0,-0.12E0), (3.0E0,4.0E0),
+     +                  (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
+     +                  (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
+     +                  (0.03E0,-0.09E0), (0.15E0,-0.03E0),
+     +                  (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
+     +                  (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
+     +                  (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.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),
+     +                  (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
+     +                  (4.0E0,5.0E0), (0.09E0,-0.12E0), (6.0E0,7.0E0),
+     +                  (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
+     +                  (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
+     +                  (0.03E0,-0.09E0), (8.0E0,9.0E0),
+     +                  (0.15E0,-0.03E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
+     +                  (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
+     +                  (0.03E0,0.03E0), (3.0E0,6.0E0),
+     +                  (-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.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
+         DO 40 NP1 = 1, 5
+            N = NP1 - 1
+            LEN = 2*MAX(N,1)
+*           .. Set vector arguments ..
+            DO 20 I = 1, LEN
+               CX(I) = CV(I,NP1,INCX)
+   20       CONTINUE
+            IF (ICASE.EQ.6) THEN
+*              .. SCNRM2 ..
+               CALL STEST1(SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1),
+     +                     SFAC)
+            ELSE IF (ICASE.EQ.7) THEN
+*              .. SCASUM ..
+               CALL STEST1(SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1),
+     +                     SFAC)
+            ELSE IF (ICASE.EQ.8) THEN
+*              .. CSCAL ..
+               CALL CSCAL(N,CA,CX,INCX)
+               CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX),
+     +                    SFAC)
+            ELSE IF (ICASE.EQ.9) THEN
+*              .. CSSCAL ..
+               CALL CSSCAL(N,SA,CX,INCX)
+               CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX),
+     +                    SFAC)
+            ELSE IF (ICASE.EQ.10) THEN
+*              .. ICAMAX ..
+               CALL ITEST1(ICAMAX(N,CX,INCX),ITRUE3(NP1))
+            ELSE
+               WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
+               STOP
+            END IF
+*
+   40    CONTINUE
+   60 CONTINUE
+*
+      INCX = 1
+      IF (ICASE.EQ.8) THEN
+*        CSCAL
+*        Add a test for alpha equal to zero.
+         CA = (0.0E0,0.0E0)
+         DO 80 I = 1, 5
+            MWPCT(I) = (0.0E0,0.0E0)
+            MWPCS(I) = (1.0E0,1.0E0)
+   80    CONTINUE
+         CALL CSCAL(5,CA,CX,INCX)
+         CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
+      ELSE IF (ICASE.EQ.9) THEN
+*        CSSCAL
+*        Add a test for alpha equal to zero.
+         SA = 0.0E0
+         DO 100 I = 1, 5
+            MWPCT(I) = (0.0E0,0.0E0)
+            MWPCS(I) = (1.0E0,1.0E0)
+  100    CONTINUE
+         CALL CSSCAL(5,SA,CX,INCX)
+         CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
+*        Add a test for alpha equal to one.
+         SA = 1.0E0
+         DO 120 I = 1, 5
+            MWPCT(I) = CX(I)
+            MWPCS(I) = CX(I)
+  120    CONTINUE
+         CALL CSSCAL(5,SA,CX,INCX)
+         CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
+*        Add a test for alpha equal to minus one.
+         SA = -1.0E0
+         DO 140 I = 1, 5
+            MWPCT(I) = -CX(I)
+            MWPCS(I) = -CX(I)
+  140    CONTINUE
+         CALL CSSCAL(5,SA,CX,INCX)
+         CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
+      END IF
+      RETURN
+      END
+      SUBROUTINE CHECK2(SFAC)
+*     .. Parameters ..
+      INTEGER           NOUT
+      PARAMETER         (NOUT=6)
+*     .. Scalar Arguments ..
+      REAL              SFAC
+*     .. Scalars in Common ..
+      INTEGER           ICASE, INCX, INCY, MODE, N
+      LOGICAL           PASS
+*     .. Local Scalars ..
+      COMPLEX           CA
+      INTEGER           I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
+*     .. Local Arrays ..
+      COMPLEX           CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
+     +                  CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
+     +                  CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7)
+      INTEGER           INCXS(4), INCYS(4), LENS(4,2), NS(4)
+*     .. External Functions ..
+      COMPLEX           CDOTC, CDOTU
+      EXTERNAL          CDOTC, CDOTU
+*     .. External Subroutines ..
+      EXTERNAL          CAXPY, CCOPY, CSWAP, CTEST
+*     .. Intrinsic Functions ..
+      INTRINSIC         ABS, MIN
+*     .. Common blocks ..
+      COMMON            /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Data statements ..
+      DATA              CA/(0.4E0,-0.7E0)/
+      DATA              INCXS/1, 2, -2, -1/
+      DATA              INCYS/1, -2, 1, -2/
+      DATA              LENS/1, 1, 2, 4, 1, 1, 3, 7/
+      DATA              NS/0, 1, 2, 4/
+      DATA              CX1/(0.7E0,-0.8E0), (-0.4E0,-0.7E0),
+     +                  (-0.1E0,-0.9E0), (0.2E0,-0.8E0),
+     +                  (-0.9E0,-0.4E0), (0.1E0,0.4E0), (-0.6E0,0.6E0)/
+      DATA              CY1/(0.6E0,-0.6E0), (-0.9E0,0.5E0),
+     +                  (0.7E0,-0.6E0), (0.1E0,-0.5E0), (-0.1E0,-0.2E0),
+     +                  (-0.5E0,-0.3E0), (0.8E0,-0.7E0)/
+      DATA              ((CT8(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.32E0,-1.41E0),
+     +                  (-1.55E0,0.5E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.32E0,-1.41E0), (-1.55E0,0.5E0),
+     +                  (0.03E0,-0.89E0), (-0.38E0,-0.96E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/
+      DATA              ((CT8(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (-0.07E0,-0.89E0),
+     +                  (-0.9E0,0.5E0), (0.42E0,-1.41E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.78E0,0.06E0), (-0.9E0,0.5E0),
+     +                  (0.06E0,-0.13E0), (0.1E0,-0.5E0),
+     +                  (-0.77E0,-0.49E0), (-0.5E0,-0.3E0),
+     +                  (0.52E0,-1.51E0)/
+      DATA              ((CT8(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (-0.07E0,-0.89E0),
+     +                  (-1.18E0,-0.31E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.78E0,0.06E0), (-1.54E0,0.97E0),
+     +                  (0.03E0,-0.89E0), (-0.18E0,-1.31E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/
+      DATA              ((CT8(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.32E0,-1.41E0), (-0.9E0,0.5E0),
+     +                  (0.05E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.32E0,-1.41E0),
+     +                  (-0.9E0,0.5E0), (0.05E0,-0.6E0), (0.1E0,-0.5E0),
+     +                  (-0.77E0,-0.49E0), (-0.5E0,-0.3E0),
+     +                  (0.32E0,-1.16E0)/
+      DATA              CT7/(0.0E0,0.0E0), (-0.06E0,-0.90E0),
+     +                  (0.65E0,-0.47E0), (-0.34E0,-1.22E0),
+     +                  (0.0E0,0.0E0), (-0.06E0,-0.90E0),
+     +                  (-0.59E0,-1.46E0), (-1.04E0,-0.04E0),
+     +                  (0.0E0,0.0E0), (-0.06E0,-0.90E0),
+     +                  (-0.83E0,0.59E0), (0.07E0,-0.37E0),
+     +                  (0.0E0,0.0E0), (-0.06E0,-0.90E0),
+     +                  (-0.76E0,-1.15E0), (-1.33E0,-1.82E0)/
+      DATA              CT6/(0.0E0,0.0E0), (0.90E0,0.06E0),
+     +                  (0.91E0,-0.77E0), (1.80E0,-0.10E0),
+     +                  (0.0E0,0.0E0), (0.90E0,0.06E0), (1.45E0,0.74E0),
+     +                  (0.20E0,0.90E0), (0.0E0,0.0E0), (0.90E0,0.06E0),
+     +                  (-0.55E0,0.23E0), (0.83E0,-0.39E0),
+     +                  (0.0E0,0.0E0), (0.90E0,0.06E0), (1.04E0,0.79E0),
+     +                  (1.95E0,1.22E0)/
+      DATA              ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7E0,-0.8E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.6E0,-0.6E0), (-0.9E0,0.5E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0),
+     +                  (-0.9E0,0.5E0), (0.7E0,-0.6E0), (0.1E0,-0.5E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/
+      DATA              ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7E0,-0.8E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.7E0,-0.6E0), (-0.4E0,-0.7E0),
+     +                  (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.8E0,-0.7E0),
+     +                  (-0.4E0,-0.7E0), (-0.1E0,-0.2E0),
+     +                  (0.2E0,-0.8E0), (0.7E0,-0.6E0), (0.1E0,0.4E0),
+     +                  (0.6E0,-0.6E0)/
+      DATA              ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7E0,-0.8E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (-0.9E0,0.5E0), (-0.4E0,-0.7E0),
+     +                  (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.1E0,-0.5E0),
+     +                  (-0.4E0,-0.7E0), (0.7E0,-0.6E0), (0.2E0,-0.8E0),
+     +                  (-0.9E0,0.5E0), (0.1E0,0.4E0), (0.6E0,-0.6E0)/
+      DATA              ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7E0,-0.8E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.6E0,-0.6E0), (0.7E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0),
+     +                  (0.7E0,-0.6E0), (-0.1E0,-0.2E0), (0.8E0,-0.7E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/
+      DATA              ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.4E0,-0.7E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0),
+     +                  (-0.4E0,-0.7E0), (-0.1E0,-0.9E0),
+     +                  (0.2E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0)/
+      DATA              ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (-0.1E0,-0.9E0), (-0.9E0,0.5E0),
+     +                  (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0),
+     +                  (-0.9E0,0.5E0), (-0.9E0,-0.4E0), (0.1E0,-0.5E0),
+     +                  (-0.1E0,-0.9E0), (-0.5E0,-0.3E0),
+     +                  (0.7E0,-0.8E0)/
+      DATA              ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (-0.1E0,-0.9E0), (0.7E0,-0.8E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0),
+     +                  (-0.9E0,-0.4E0), (-0.1E0,-0.9E0),
+     +                  (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0)/
+      DATA              ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.9E0,0.5E0),
+     +                  (-0.4E0,-0.7E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0),
+     +                  (-0.9E0,0.5E0), (-0.4E0,-0.7E0), (0.1E0,-0.5E0),
+     +                  (-0.1E0,-0.9E0), (-0.5E0,-0.3E0),
+     +                  (0.2E0,-0.8E0)/
+      DATA              CSIZE1/(0.0E0,0.0E0), (0.9E0,0.9E0),
+     +                  (1.63E0,1.73E0), (2.90E0,2.78E0)/
+      DATA              CSIZE3/(0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (1.17E0,1.17E0),
+     +                  (1.17E0,1.17E0), (1.17E0,1.17E0),
+     +                  (1.17E0,1.17E0), (1.17E0,1.17E0),
+     +                  (1.17E0,1.17E0), (1.17E0,1.17E0)/
+      DATA              CSIZE2/(0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
+     +                  (0.0E0,0.0E0), (0.0E0,0.0E0), (1.54E0,1.54E0),
+     +                  (1.54E0,1.54E0), (1.54E0,1.54E0),
+     +                  (1.54E0,1.54E0), (1.54E0,1.54E0),
+     +                  (1.54E0,1.54E0), (1.54E0,1.54E0)/
+*     .. Executable Statements ..
+      DO 60 KI = 1, 4
+         INCX = INCXS(KI)
+         INCY = INCYS(KI)
+         MX = ABS(INCX)
+         MY = ABS(INCY)
+*
+         DO 40 KN = 1, 4
+            N = NS(KN)
+            KSIZE = MIN(2,KN)
+            LENX = LENS(KN,MX)
+            LENY = LENS(KN,MY)
+*           .. initialize all argument arrays ..
+            DO 20 I = 1, 7
+               CX(I) = CX1(I)
+               CY(I) = CY1(I)
+   20       CONTINUE
+            IF (ICASE.EQ.1) THEN
+*              .. CDOTC ..
+               CDOT(1) = CDOTC(N,CX,INCX,CY,INCY)
+               CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC)
+            ELSE IF (ICASE.EQ.2) THEN
+*              .. CDOTU ..
+               CDOT(1) = CDOTU(N,CX,INCX,CY,INCY)
+               CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC)
+            ELSE IF (ICASE.EQ.3) THEN
+*              .. CAXPY ..
+               CALL CAXPY(N,CA,CX,INCX,CY,INCY)
+               CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC)
+            ELSE IF (ICASE.EQ.4) THEN
+*              .. CCOPY ..
+               CALL CCOPY(N,CX,INCX,CY,INCY)
+               CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0)
+            ELSE IF (ICASE.EQ.5) THEN
+*              .. CSWAP ..
+               CALL CSWAP(N,CX,INCX,CY,INCY)
+               CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0E0)
+               CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0)
+            ELSE
+               WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
+               STOP
+            END IF
+*
+   40    CONTINUE
+   60 CONTINUE
+      RETURN
+      END
+      SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
+*     ********************************* STEST **************************
+*
+*     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
+*     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
+*     NEGLIGIBLE.
+*
+*     C. L. LAWSON, JPL, 1974 DEC 10
+*
+*     .. Parameters ..
+      INTEGER          NOUT
+      REAL             ZERO
+      PARAMETER        (NOUT=6, ZERO=0.0E0)
+*     .. Scalar Arguments ..
+      REAL             SFAC
+      INTEGER          LEN
+*     .. Array Arguments ..
+      REAL             SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
+*     .. Scalars in Common ..
+      INTEGER          ICASE, INCX, INCY, MODE, N
+      LOGICAL          PASS
+*     .. Local Scalars ..
+      REAL             SD
+      INTEGER          I
+*     .. External Functions ..
+      REAL             SDIFF
+      EXTERNAL         SDIFF
+*     .. Intrinsic Functions ..
+      INTRINSIC        ABS
+*     .. Common blocks ..
+      COMMON           /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Executable Statements ..
+*
+      DO 40 I = 1, LEN
+         SD = SCOMP(I) - STRUE(I)
+         IF (ABS(SFAC*SD) .LE. ABS(SSIZE(I))*EPSILON(ZERO))
+     +       GO TO 40
+*
+*                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
+*
+         IF ( .NOT. PASS) GO TO 20
+*                             PRINT FAIL MESSAGE AND HEADER.
+         PASS = .FALSE.
+         WRITE (NOUT,99999)
+         WRITE (NOUT,99998)
+   20    WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I),
+     +     STRUE(I), SD, SSIZE(I)
+   40 CONTINUE
+      RETURN
+*
+99999 FORMAT ('                                       FAIL')
+99998 FORMAT (/' CASE  N INCX INCY MODE  I                            ',
+     +       ' COMP(I)                             TRUE(I)  DIFFERENCE',
+     +       '     SIZE(I)',/1X)
+99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4)
+      END
+      SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
+*     ************************* STEST1 *****************************
+*
+*     THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
+*     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
+*     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
+*
+*     C.L. LAWSON, JPL, 1978 DEC 6
+*
+*     .. Scalar Arguments ..
+      REAL              SCOMP1, SFAC, STRUE1
+*     .. Array Arguments ..
+      REAL              SSIZE(*)
+*     .. Local Arrays ..
+      REAL              SCOMP(1), STRUE(1)
+*     .. External Subroutines ..
+      EXTERNAL          STEST
+*     .. Executable Statements ..
+*
+      SCOMP(1) = SCOMP1
+      STRUE(1) = STRUE1
+      CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
+*
+      RETURN
+      END
+      REAL             FUNCTION SDIFF(SA,SB)
+*     ********************************* SDIFF **************************
+*     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15
+*
+*     .. Scalar Arguments ..
+      REAL                            SA, SB
+*     .. Executable Statements ..
+      SDIFF = SA - SB
+      RETURN
+      END
+      SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC)
+*     **************************** CTEST *****************************
+*
+*     C.L. LAWSON, JPL, 1978 DEC 6
+*
+*     .. Scalar Arguments ..
+      REAL             SFAC
+      INTEGER          LEN
+*     .. Array Arguments ..
+      COMPLEX          CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
+*     .. Local Scalars ..
+      INTEGER          I
+*     .. Local Arrays ..
+      REAL             SCOMP(20), SSIZE(20), STRUE(20)
+*     .. External Subroutines ..
+      EXTERNAL         STEST
+*     .. Intrinsic Functions ..
+      INTRINSIC        AIMAG, REAL
+*     .. Executable Statements ..
+      DO 20 I = 1, LEN
+         SCOMP(2*I-1) = REAL(CCOMP(I))
+         SCOMP(2*I) = AIMAG(CCOMP(I))
+         STRUE(2*I-1) = REAL(CTRUE(I))
+         STRUE(2*I) = AIMAG(CTRUE(I))
+         SSIZE(2*I-1) = REAL(CSIZE(I))
+         SSIZE(2*I) = AIMAG(CSIZE(I))
+   20 CONTINUE
+*
+      CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC)
+      RETURN
+      END
+      SUBROUTINE ITEST1(ICOMP,ITRUE)
+*     ********************************* ITEST1 *************************
+*
+*     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
+*     EQUALITY.
+*     C. L. LAWSON, JPL, 1974 DEC 10
+*
+*     .. Parameters ..
+      INTEGER           NOUT
+      PARAMETER         (NOUT=6)
+*     .. Scalar Arguments ..
+      INTEGER           ICOMP, ITRUE
+*     .. Scalars in Common ..
+      INTEGER           ICASE, INCX, INCY, MODE, N
+      LOGICAL           PASS
+*     .. Local Scalars ..
+      INTEGER           ID
+*     .. Common blocks ..
+      COMMON            /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Executable Statements ..
+      IF (ICOMP.EQ.ITRUE) GO TO 40
+*
+*                            HERE ICOMP IS NOT EQUAL TO ITRUE.
+*
+      IF ( .NOT. PASS) GO TO 20
+*                             PRINT FAIL MESSAGE AND HEADER.
+      PASS = .FALSE.
+      WRITE (NOUT,99999)
+      WRITE (NOUT,99998)
+   20 ID = ICOMP - ITRUE
+      WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID
+   40 CONTINUE
+      RETURN
+*
+99999 FORMAT ('                                       FAIL')
+99998 FORMAT (/' CASE  N INCX INCY MODE                               ',
+     +       ' COMP                                TRUE     DIFFERENCE',
+     +       /1X)
+99997 FORMAT (1X,I4,I3,3I5,2I36,I12)
+      END

cs440-acg/ext/eigen/blas/testing/cblat2.dat

@@ -0,0 +1,35 @@
+'cblat2.summ'     NAME OF SUMMARY OUTPUT FILE
+6                 UNIT NUMBER OF SUMMARY FILE
+'cblat2.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.

cs440-acg/ext/eigen/blas/testing/cblat3.dat

@@ -0,0 +1,23 @@
+'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.
+F        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.

cs440-acg/ext/eigen/blas/testing/dblat2.dat

@@ -0,0 +1,34 @@
+'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.

cs440-acg/ext/eigen/blas/testing/dblat3.dat

@@ -0,0 +1,20 @@
+'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.

cs440-acg/ext/eigen/blas/testing/runblastest.sh

@@ -0,0 +1,45 @@
+#!/bin/bash
+
+black='\E[30m'
+red='\E[31m'
+green='\E[32m'
+yellow='\E[33m'
+blue='\E[34m'
+magenta='\E[35m'
+cyan='\E[36m'
+white='\E[37m'
+
+if [ -f $2 ]; then
+  data=$2
+  if [ -f $1.summ ]; then rm $1.summ; fi
+  if [ -f $1.snap ]; then rm $1.snap; fi
+else
+  data=$1
+fi
+
+if ! ./$1 < $data > /dev/null 2> .runtest.log ; then
+  echo -e  $red Test $1 failed: $black
+  echo -e $blue
+  cat .runtest.log
+  echo -e $black
+  exit 1
+else
+  if [ -f $1.summ ]; then
+    if [ `grep "FATAL ERROR" $1.summ | wc -l` -gt 0 ]; then
+      echo -e  $red "Test $1 failed (FATAL ERROR, read the file $1.summ for details)" $black
+      echo -e $blue
+      cat .runtest.log
+      echo -e $black
+      exit 1;
+    fi
+
+    if [ `grep "FAILED THE TESTS OF ERROR-EXITS" $1.summ | wc -l` -gt 0 ]; then
+      echo -e  $red "Test $1 failed (FAILED THE TESTS OF ERROR-EXITS, read the file $1.summ for details)" $black
+      echo -e $blue
+      cat .runtest.log
+      echo -e $black
+      exit 1;
+    fi      
+  fi
+  echo -e $green Test $1 passed$black
+fi

cs440-acg/ext/eigen/blas/testing/sblat2.dat

@@ -0,0 +1,34 @@
+'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.

cs440-acg/ext/eigen/blas/testing/sblat3.dat

@@ -0,0 +1,20 @@
+'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.

cs440-acg/ext/eigen/blas/testing/zblat1.f

@@ -0,0 +1,724 @@
+*> \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
+*
+*  -- 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)
+*     .. Scalars in Common ..
+      INTEGER          ICASE, INCX, INCY, MODE, N
+      LOGICAL          PASS
+*     .. Local Scalars ..
+      DOUBLE PRECISION SFAC
+      INTEGER          IC
+*     .. External Subroutines ..
+      EXTERNAL         CHECK1, CHECK2, HEADER
+*     .. Common blocks ..
+      COMMON           /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Data statements ..
+      DATA             SFAC/9.765625D-4/
+*     .. Executable Statements ..
+      WRITE (NOUT,99999)
+      DO 20 IC = 1, 10
+         ICASE = IC
+         CALL HEADER
+*
+*        Initialize PASS, INCX, INCY, and MODE for a new case.
+*        The value 9999 for INCX, INCY or MODE will appear in the
+*        detailed  output, if any, for cases that do not involve
+*        these parameters.
+*
+         PASS = .TRUE.
+         INCX = 9999
+         INCY = 9999
+         MODE = 9999
+         IF (ICASE.LE.5) THEN
+            CALL CHECK2(SFAC)
+         ELSE IF (ICASE.GE.6) THEN
+            CALL CHECK1(SFAC)
+         END IF
+*        -- Print
+         IF (PASS) WRITE (NOUT,99998)
+   20 CONTINUE
+      STOP
+*
+99999 FORMAT (' Complex BLAS Test Program Results',/1X)
+99998 FORMAT ('                                    ----- PASS -----')
+      END
+      SUBROUTINE HEADER
+*     .. Parameters ..
+      INTEGER          NOUT
+      PARAMETER        (NOUT=6)
+*     .. Scalars in Common ..
+      INTEGER          ICASE, INCX, INCY, MODE, N
+      LOGICAL          PASS
+*     .. Local Arrays ..
+      CHARACTER*6      L(10)
+*     .. Common blocks ..
+      COMMON           /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Data statements ..
+      DATA             L(1)/'ZDOTC '/
+      DATA             L(2)/'ZDOTU '/
+      DATA             L(3)/'ZAXPY '/
+      DATA             L(4)/'ZCOPY '/
+      DATA             L(5)/'ZSWAP '/
+      DATA             L(6)/'DZNRM2'/
+      DATA             L(7)/'DZASUM'/
+      DATA             L(8)/'ZSCAL '/
+      DATA             L(9)/'ZDSCAL'/
+      DATA             L(10)/'IZAMAX'/
+*     .. Executable Statements ..
+      WRITE (NOUT,99999) ICASE, L(ICASE)
+      RETURN
+*
+99999 FORMAT (/' Test of subprogram number',I3,12X,A6)
+      END
+      SUBROUTINE CHECK1(SFAC)
+*     .. Parameters ..
+      INTEGER           NOUT
+      PARAMETER         (NOUT=6)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION  SFAC
+*     .. Scalars in Common ..
+      INTEGER           ICASE, INCX, INCY, MODE, N
+      LOGICAL           PASS
+*     .. Local Scalars ..
+      COMPLEX*16        CA
+      DOUBLE PRECISION  SA
+      INTEGER           I, J, LEN, NP1
+*     .. Local Arrays ..
+      COMPLEX*16        CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8),
+     +                  MWPCS(5), MWPCT(5)
+      DOUBLE PRECISION  STRUE2(5), STRUE4(5)
+      INTEGER           ITRUE3(5)
+*     .. External Functions ..
+      DOUBLE PRECISION  DZASUM, DZNRM2
+      INTEGER           IZAMAX
+      EXTERNAL          DZASUM, DZNRM2, IZAMAX
+*     .. External Subroutines ..
+      EXTERNAL          ZSCAL, ZDSCAL, CTEST, ITEST1, STEST1
+*     .. Intrinsic Functions ..
+      INTRINSIC         MAX
+*     .. Common blocks ..
+      COMMON            /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Data statements ..
+      DATA              SA, CA/0.3D0, (0.4D0,-0.7D0)/
+      DATA              ((CV(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),
+     +                  (1.0D0,2.0D0), (0.3D0,-0.4D0), (3.0D0,4.0D0),
+     +                  (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
+     +                  (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
+     +                  (0.1D0,-0.3D0), (0.5D0,-0.1D0), (5.0D0,6.0D0),
+     +                  (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
+     +                  (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.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),
+     +                  (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
+     +                  (4.0D0,5.0D0), (0.3D0,-0.4D0), (6.0D0,7.0D0),
+     +                  (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
+     +                  (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
+     +                  (0.1D0,-0.3D0), (8.0D0,9.0D0), (0.5D0,-0.1D0),
+     +                  (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
+     +                  (2.0D0,5.0D0), (2.0D0,5.0D0), (0.1D0,0.1D0),
+     +                  (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.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),
+     +                  (1.0D0,2.0D0), (-0.16D0,-0.37D0), (3.0D0,4.0D0),
+     +                  (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
+     +                  (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
+     +                  (-0.17D0,-0.19D0), (0.13D0,-0.39D0),
+     +                  (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
+     +                  (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
+     +                  (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.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),
+     +                  (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
+     +                  (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
+     +                  (4.0D0,5.0D0), (-0.16D0,-0.37D0), (6.0D0,7.0D0),
+     +                  (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
+     +                  (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
+     +                  (-0.17D0,-0.19D0), (8.0D0,9.0D0),
+     +                  (0.13D0,-0.39D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
+     +                  (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
+     +                  (0.11D0,-0.03D0), (3.0D0,6.0D0),
+     +                  (-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.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),
+     +                  (1.0D0,2.0D0), (0.09D0,-0.12D0), (3.0D0,4.0D0),
+     +                  (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
+     +                  (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
+     +                  (0.03D0,-0.09D0), (0.15D0,-0.03D0),
+     +                  (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
+     +                  (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
+     +                  (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.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),
+     +                  (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
+     +                  (4.0D0,5.0D0), (0.09D0,-0.12D0), (6.0D0,7.0D0),
+     +                  (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
+     +                  (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
+     +                  (0.03D0,-0.09D0), (8.0D0,9.0D0),
+     +                  (0.15D0,-0.03D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
+     +                  (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
+     +                  (0.03D0,0.03D0), (3.0D0,6.0D0),
+     +                  (-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.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
+         DO 40 NP1 = 1, 5
+            N = NP1 - 1
+            LEN = 2*MAX(N,1)
+*           .. Set vector arguments ..
+            DO 20 I = 1, LEN
+               CX(I) = CV(I,NP1,INCX)
+   20       CONTINUE
+            IF (ICASE.EQ.6) THEN
+*              .. DZNRM2 ..
+               CALL STEST1(DZNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1),
+     +                     SFAC)
+            ELSE IF (ICASE.EQ.7) THEN
+*              .. DZASUM ..
+               CALL STEST1(DZASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1),
+     +                     SFAC)
+            ELSE IF (ICASE.EQ.8) THEN
+*              .. ZSCAL ..
+               CALL ZSCAL(N,CA,CX,INCX)
+               CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX),
+     +                    SFAC)
+            ELSE IF (ICASE.EQ.9) THEN
+*              .. ZDSCAL ..
+               CALL ZDSCAL(N,SA,CX,INCX)
+               CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX),
+     +                    SFAC)
+            ELSE IF (ICASE.EQ.10) THEN
+*              .. IZAMAX ..
+               CALL ITEST1(IZAMAX(N,CX,INCX),ITRUE3(NP1))
+            ELSE
+               WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
+               STOP
+            END IF
+*
+   40    CONTINUE
+   60 CONTINUE
+*
+      INCX = 1
+      IF (ICASE.EQ.8) THEN
+*        ZSCAL
+*        Add a test for alpha equal to zero.
+         CA = (0.0D0,0.0D0)
+         DO 80 I = 1, 5
+            MWPCT(I) = (0.0D0,0.0D0)
+            MWPCS(I) = (1.0D0,1.0D0)
+   80    CONTINUE
+         CALL ZSCAL(5,CA,CX,INCX)
+         CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
+      ELSE IF (ICASE.EQ.9) THEN
+*        ZDSCAL
+*        Add a test for alpha equal to zero.
+         SA = 0.0D0
+         DO 100 I = 1, 5
+            MWPCT(I) = (0.0D0,0.0D0)
+            MWPCS(I) = (1.0D0,1.0D0)
+  100    CONTINUE
+         CALL ZDSCAL(5,SA,CX,INCX)
+         CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
+*        Add a test for alpha equal to one.
+         SA = 1.0D0
+         DO 120 I = 1, 5
+            MWPCT(I) = CX(I)
+            MWPCS(I) = CX(I)
+  120    CONTINUE
+         CALL ZDSCAL(5,SA,CX,INCX)
+         CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
+*        Add a test for alpha equal to minus one.
+         SA = -1.0D0
+         DO 140 I = 1, 5
+            MWPCT(I) = -CX(I)
+            MWPCS(I) = -CX(I)
+  140    CONTINUE
+         CALL ZDSCAL(5,SA,CX,INCX)
+         CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
+      END IF
+      RETURN
+      END
+      SUBROUTINE CHECK2(SFAC)
+*     .. Parameters ..
+      INTEGER           NOUT
+      PARAMETER         (NOUT=6)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION  SFAC
+*     .. Scalars in Common ..
+      INTEGER           ICASE, INCX, INCY, MODE, N
+      LOGICAL           PASS
+*     .. Local Scalars ..
+      COMPLEX*16        CA
+      INTEGER           I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
+*     .. Local Arrays ..
+      COMPLEX*16        CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
+     +                  CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
+     +                  CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7)
+      INTEGER           INCXS(4), INCYS(4), LENS(4,2), NS(4)
+*     .. External Functions ..
+      COMPLEX*16        ZDOTC, ZDOTU
+      EXTERNAL          ZDOTC, ZDOTU
+*     .. External Subroutines ..
+      EXTERNAL          ZAXPY, ZCOPY, ZSWAP, CTEST
+*     .. Intrinsic Functions ..
+      INTRINSIC         ABS, MIN
+*     .. Common blocks ..
+      COMMON            /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Data statements ..
+      DATA              CA/(0.4D0,-0.7D0)/
+      DATA              INCXS/1, 2, -2, -1/
+      DATA              INCYS/1, -2, 1, -2/
+      DATA              LENS/1, 1, 2, 4, 1, 1, 3, 7/
+      DATA              NS/0, 1, 2, 4/
+      DATA              CX1/(0.7D0,-0.8D0), (-0.4D0,-0.7D0),
+     +                  (-0.1D0,-0.9D0), (0.2D0,-0.8D0),
+     +                  (-0.9D0,-0.4D0), (0.1D0,0.4D0), (-0.6D0,0.6D0)/
+      DATA              CY1/(0.6D0,-0.6D0), (-0.9D0,0.5D0),
+     +                  (0.7D0,-0.6D0), (0.1D0,-0.5D0), (-0.1D0,-0.2D0),
+     +                  (-0.5D0,-0.3D0), (0.8D0,-0.7D0)/
+      DATA              ((CT8(I,J,1),I=1,7),J=1,4)/(0.6D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.32D0,-1.41D0),
+     +                  (-1.55D0,0.5D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.32D0,-1.41D0), (-1.55D0,0.5D0),
+     +                  (0.03D0,-0.89D0), (-0.38D0,-0.96D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/
+      DATA              ((CT8(I,J,2),I=1,7),J=1,4)/(0.6D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (-0.07D0,-0.89D0),
+     +                  (-0.9D0,0.5D0), (0.42D0,-1.41D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.78D0,0.06D0), (-0.9D0,0.5D0),
+     +                  (0.06D0,-0.13D0), (0.1D0,-0.5D0),
+     +                  (-0.77D0,-0.49D0), (-0.5D0,-0.3D0),
+     +                  (0.52D0,-1.51D0)/
+      DATA              ((CT8(I,J,3),I=1,7),J=1,4)/(0.6D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (-0.07D0,-0.89D0),
+     +                  (-1.18D0,-0.31D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.78D0,0.06D0), (-1.54D0,0.97D0),
+     +                  (0.03D0,-0.89D0), (-0.18D0,-1.31D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/
+      DATA              ((CT8(I,J,4),I=1,7),J=1,4)/(0.6D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.32D0,-1.41D0), (-0.9D0,0.5D0),
+     +                  (0.05D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.32D0,-1.41D0),
+     +                  (-0.9D0,0.5D0), (0.05D0,-0.6D0), (0.1D0,-0.5D0),
+     +                  (-0.77D0,-0.49D0), (-0.5D0,-0.3D0),
+     +                  (0.32D0,-1.16D0)/
+      DATA              CT7/(0.0D0,0.0D0), (-0.06D0,-0.90D0),
+     +                  (0.65D0,-0.47D0), (-0.34D0,-1.22D0),
+     +                  (0.0D0,0.0D0), (-0.06D0,-0.90D0),
+     +                  (-0.59D0,-1.46D0), (-1.04D0,-0.04D0),
+     +                  (0.0D0,0.0D0), (-0.06D0,-0.90D0),
+     +                  (-0.83D0,0.59D0), (0.07D0,-0.37D0),
+     +                  (0.0D0,0.0D0), (-0.06D0,-0.90D0),
+     +                  (-0.76D0,-1.15D0), (-1.33D0,-1.82D0)/
+      DATA              CT6/(0.0D0,0.0D0), (0.90D0,0.06D0),
+     +                  (0.91D0,-0.77D0), (1.80D0,-0.10D0),
+     +                  (0.0D0,0.0D0), (0.90D0,0.06D0), (1.45D0,0.74D0),
+     +                  (0.20D0,0.90D0), (0.0D0,0.0D0), (0.90D0,0.06D0),
+     +                  (-0.55D0,0.23D0), (0.83D0,-0.39D0),
+     +                  (0.0D0,0.0D0), (0.90D0,0.06D0), (1.04D0,0.79D0),
+     +                  (1.95D0,1.22D0)/
+      DATA              ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7D0,-0.8D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.6D0,-0.6D0), (-0.9D0,0.5D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.6D0,-0.6D0),
+     +                  (-0.9D0,0.5D0), (0.7D0,-0.6D0), (0.1D0,-0.5D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/
+      DATA              ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7D0,-0.8D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.7D0,-0.6D0), (-0.4D0,-0.7D0),
+     +                  (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.8D0,-0.7D0),
+     +                  (-0.4D0,-0.7D0), (-0.1D0,-0.2D0),
+     +                  (0.2D0,-0.8D0), (0.7D0,-0.6D0), (0.1D0,0.4D0),
+     +                  (0.6D0,-0.6D0)/
+      DATA              ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7D0,-0.8D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (-0.9D0,0.5D0), (-0.4D0,-0.7D0),
+     +                  (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.1D0,-0.5D0),
+     +                  (-0.4D0,-0.7D0), (0.7D0,-0.6D0), (0.2D0,-0.8D0),
+     +                  (-0.9D0,0.5D0), (0.1D0,0.4D0), (0.6D0,-0.6D0)/
+      DATA              ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7D0,-0.8D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.6D0,-0.6D0), (0.7D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.6D0,-0.6D0),
+     +                  (0.7D0,-0.6D0), (-0.1D0,-0.2D0), (0.8D0,-0.7D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/
+      DATA              ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.7D0,-0.8D0), (-0.4D0,-0.7D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.7D0,-0.8D0),
+     +                  (-0.4D0,-0.7D0), (-0.1D0,-0.9D0),
+     +                  (0.2D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0)/
+      DATA              ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (-0.1D0,-0.9D0), (-0.9D0,0.5D0),
+     +                  (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (-0.6D0,0.6D0),
+     +                  (-0.9D0,0.5D0), (-0.9D0,-0.4D0), (0.1D0,-0.5D0),
+     +                  (-0.1D0,-0.9D0), (-0.5D0,-0.3D0),
+     +                  (0.7D0,-0.8D0)/
+      DATA              ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (-0.1D0,-0.9D0), (0.7D0,-0.8D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (-0.6D0,0.6D0),
+     +                  (-0.9D0,-0.4D0), (-0.1D0,-0.9D0),
+     +                  (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0)/
+      DATA              ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6D0,-0.6D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.7D0,-0.8D0), (-0.9D0,0.5D0),
+     +                  (-0.4D0,-0.7D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.7D0,-0.8D0),
+     +                  (-0.9D0,0.5D0), (-0.4D0,-0.7D0), (0.1D0,-0.5D0),
+     +                  (-0.1D0,-0.9D0), (-0.5D0,-0.3D0),
+     +                  (0.2D0,-0.8D0)/
+      DATA              CSIZE1/(0.0D0,0.0D0), (0.9D0,0.9D0),
+     +                  (1.63D0,1.73D0), (2.90D0,2.78D0)/
+      DATA              CSIZE3/(0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (1.17D0,1.17D0),
+     +                  (1.17D0,1.17D0), (1.17D0,1.17D0),
+     +                  (1.17D0,1.17D0), (1.17D0,1.17D0),
+     +                  (1.17D0,1.17D0), (1.17D0,1.17D0)/
+      DATA              CSIZE2/(0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
+     +                  (0.0D0,0.0D0), (0.0D0,0.0D0), (1.54D0,1.54D0),
+     +                  (1.54D0,1.54D0), (1.54D0,1.54D0),
+     +                  (1.54D0,1.54D0), (1.54D0,1.54D0),
+     +                  (1.54D0,1.54D0), (1.54D0,1.54D0)/
+*     .. Executable Statements ..
+      DO 60 KI = 1, 4
+         INCX = INCXS(KI)
+         INCY = INCYS(KI)
+         MX = ABS(INCX)
+         MY = ABS(INCY)
+*
+         DO 40 KN = 1, 4
+            N = NS(KN)
+            KSIZE = MIN(2,KN)
+            LENX = LENS(KN,MX)
+            LENY = LENS(KN,MY)
+*           .. initialize all argument arrays ..
+            DO 20 I = 1, 7
+               CX(I) = CX1(I)
+               CY(I) = CY1(I)
+   20       CONTINUE
+            IF (ICASE.EQ.1) THEN
+*              .. ZDOTC ..
+               CDOT(1) = ZDOTC(N,CX,INCX,CY,INCY)
+               CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC)
+            ELSE IF (ICASE.EQ.2) THEN
+*              .. ZDOTU ..
+               CDOT(1) = ZDOTU(N,CX,INCX,CY,INCY)
+               CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC)
+            ELSE IF (ICASE.EQ.3) THEN
+*              .. ZAXPY ..
+               CALL ZAXPY(N,CA,CX,INCX,CY,INCY)
+               CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC)
+            ELSE IF (ICASE.EQ.4) THEN
+*              .. ZCOPY ..
+               CALL ZCOPY(N,CX,INCX,CY,INCY)
+               CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0)
+            ELSE IF (ICASE.EQ.5) THEN
+*              .. ZSWAP ..
+               CALL ZSWAP(N,CX,INCX,CY,INCY)
+               CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0D0)
+               CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0)
+            ELSE
+               WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
+               STOP
+            END IF
+*
+   40    CONTINUE
+   60 CONTINUE
+      RETURN
+      END
+      SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
+*     ********************************* STEST **************************
+*
+*     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
+*     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
+*     NEGLIGIBLE.
+*
+*     C. L. LAWSON, JPL, 1974 DEC 10
+*
+*     .. Parameters ..
+      INTEGER          NOUT
+      DOUBLE PRECISION ZERO
+      PARAMETER        (NOUT=6, ZERO=0.0D0)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION SFAC
+      INTEGER          LEN
+*     .. Array Arguments ..
+      DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
+*     .. Scalars in Common ..
+      INTEGER          ICASE, INCX, INCY, MODE, N
+      LOGICAL          PASS
+*     .. Local Scalars ..
+      DOUBLE PRECISION SD
+      INTEGER          I
+*     .. External Functions ..
+      DOUBLE PRECISION SDIFF
+      EXTERNAL         SDIFF
+*     .. Intrinsic Functions ..
+      INTRINSIC        ABS
+*     .. Common blocks ..
+      COMMON           /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Executable Statements ..
+*
+      DO 40 I = 1, LEN
+         SD = SCOMP(I) - STRUE(I)
+         IF (ABS(SFAC*SD) .LE. ABS(SSIZE(I))*EPSILON(ZERO))
+     +       GO TO 40
+*
+*                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
+*
+         IF ( .NOT. PASS) GO TO 20
+*                             PRINT FAIL MESSAGE AND HEADER.
+         PASS = .FALSE.
+         WRITE (NOUT,99999)
+         WRITE (NOUT,99998)
+   20    WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I),
+     +     STRUE(I), SD, SSIZE(I)
+   40 CONTINUE
+      RETURN
+*
+99999 FORMAT ('                                       FAIL')
+99998 FORMAT (/' CASE  N INCX INCY MODE  I                            ',
+     +       ' COMP(I)                             TRUE(I)  DIFFERENCE',
+     +       '     SIZE(I)',/1X)
+99997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4)
+      END
+      SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
+*     ************************* STEST1 *****************************
+*
+*     THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
+*     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
+*     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
+*
+*     C.L. LAWSON, JPL, 1978 DEC 6
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION  SCOMP1, SFAC, STRUE1
+*     .. Array Arguments ..
+      DOUBLE PRECISION  SSIZE(*)
+*     .. Local Arrays ..
+      DOUBLE PRECISION  SCOMP(1), STRUE(1)
+*     .. External Subroutines ..
+      EXTERNAL          STEST
+*     .. Executable Statements ..
+*
+      SCOMP(1) = SCOMP1
+      STRUE(1) = STRUE1
+      CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
+*
+      RETURN
+      END
+      DOUBLE PRECISION FUNCTION SDIFF(SA,SB)
+*     ********************************* SDIFF **************************
+*     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION                SA, SB
+*     .. Executable Statements ..
+      SDIFF = SA - SB
+      RETURN
+      END
+      SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC)
+*     **************************** CTEST *****************************
+*
+*     C.L. LAWSON, JPL, 1978 DEC 6
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION SFAC
+      INTEGER          LEN
+*     .. Array Arguments ..
+      COMPLEX*16       CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
+*     .. Local Scalars ..
+      INTEGER          I
+*     .. Local Arrays ..
+      DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20)
+*     .. External Subroutines ..
+      EXTERNAL         STEST
+*     .. Intrinsic Functions ..
+      INTRINSIC        DIMAG, DBLE
+*     .. Executable Statements ..
+      DO 20 I = 1, LEN
+         SCOMP(2*I-1) = DBLE(CCOMP(I))
+         SCOMP(2*I) = DIMAG(CCOMP(I))
+         STRUE(2*I-1) = DBLE(CTRUE(I))
+         STRUE(2*I) = DIMAG(CTRUE(I))
+         SSIZE(2*I-1) = DBLE(CSIZE(I))
+         SSIZE(2*I) = DIMAG(CSIZE(I))
+   20 CONTINUE
+*
+      CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC)
+      RETURN
+      END
+      SUBROUTINE ITEST1(ICOMP,ITRUE)
+*     ********************************* ITEST1 *************************
+*
+*     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
+*     EQUALITY.
+*     C. L. LAWSON, JPL, 1974 DEC 10
+*
+*     .. Parameters ..
+      INTEGER           NOUT
+      PARAMETER         (NOUT=6)
+*     .. Scalar Arguments ..
+      INTEGER           ICOMP, ITRUE
+*     .. Scalars in Common ..
+      INTEGER           ICASE, INCX, INCY, MODE, N
+      LOGICAL           PASS
+*     .. Local Scalars ..
+      INTEGER           ID
+*     .. Common blocks ..
+      COMMON            /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+*     .. Executable Statements ..
+      IF (ICOMP.EQ.ITRUE) GO TO 40
+*
+*                            HERE ICOMP IS NOT EQUAL TO ITRUE.
+*
+      IF ( .NOT. PASS) GO TO 20
+*                             PRINT FAIL MESSAGE AND HEADER.
+      PASS = .FALSE.
+      WRITE (NOUT,99999)
+      WRITE (NOUT,99998)
+   20 ID = ICOMP - ITRUE
+      WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID
+   40 CONTINUE
+      RETURN
+*
+99999 FORMAT ('                                       FAIL')
+99998 FORMAT (/' CASE  N INCX INCY MODE                               ',
+     +       ' COMP                                TRUE     DIFFERENCE',
+     +       /1X)
+99997 FORMAT (1X,I4,I3,3I5,2I36,I12)
+      END

cs440-acg/ext/eigen/blas/testing/zblat2.dat

@@ -0,0 +1,35 @@
+'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.

cs440-acg/ext/eigen/blas/testing/zblat3.dat

@@ -0,0 +1,23 @@
+'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.
+F        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.

cs440-acg/ext/eigen/blas/xerbla.cpp

@@ -0,0 +1,23 @@
+
+#include <stdio.h>
+
+#if (defined __GNUC__) && (!defined __MINGW32__) && (!defined __CYGWIN__)
+#define EIGEN_WEAK_LINKING __attribute__ ((weak))
+#else
+#define EIGEN_WEAK_LINKING
+#endif
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+
+EIGEN_WEAK_LINKING int xerbla_(const char * msg, int *info, int)
+{
+  printf("Eigen BLAS ERROR #%i: %s\n", *info, msg );
+  return 0;
+}
+
+#ifdef __cplusplus
+}
+#endif