LinkNexus/huoyi_deploy
20
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

initial commit

Browse Source
This commit is contained in:
huangweifeng
2026-10-22 09:23:54 +08:00
commit 63f557a39f
4448 changed files with 584487 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
third_party/eigen/blas/BandTriangularSolver.h
Vendored
+84
View File
@@ -0,0 +1,84 @@
// 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 Eigen {
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);
std::conditional_t<ConjLhs, const CwiseUnaryOp<typename internal::scalar_conjugate_op<LhsScalar>, LhsMap>,
const LhsMap&>
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);
std::conditional_t<ConjLhs, const CwiseUnaryOp<typename internal::scalar_conjugate_op<LhsScalar>, LhsMap>,
const LhsMap&>
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);
}
}
}
};
} // namespace internal
} // namespace Eigen
#endif // EIGEN_BAND_TRIANGULARSOLVER_H
third_party/eigen/blas/CMakeLists.txt
Vendored
+46
View File
@@ -0,0 +1,46 @@
project(EigenBlas CXX)
if(EIGEN_BUILD_BLAS)
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/complexdots.c
)
set(EIGEN_BLAS_TARGETS "")
add_library(eigen_blas_static STATIC ${EigenBlas_SRCS})
list(APPEND EIGEN_BLAS_TARGETS eigen_blas_static)
if (EIGEN_BUILD_SHARED_LIBS)
add_library(eigen_blas SHARED ${EigenBlas_SRCS})
list(APPEND EIGEN_BLAS_TARGETS eigen_blas)
endif()
foreach(target IN LISTS EIGEN_BLAS_TARGETS)
if(EIGEN_STANDARD_LIBRARIES_TO_LINK_TO)
target_link_libraries(${target} ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO})
endif()
add_dependencies(blas ${target})
install(TARGETS ${target}
RUNTIME DESTINATION bin
LIBRARY DESTINATION lib
ARCHIVE DESTINATION lib)
endforeach()
if(EIGEN_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()
third_party/eigen/blas/GeneralRank1Update.h
Vendored
+42
View File
@@ -0,0 +1,42 @@
// 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 Eigen {
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);
}
};
} // namespace internal
} // namespace Eigen
#endif // EIGEN_GENERAL_RANK1UPDATE_H
third_party/eigen/blas/PackedSelfadjointProduct.h
Vendored
+52
View File
@@ -0,0 +1,52 @@
// 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 Eigen {
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);
}
};
} // namespace internal
} // namespace Eigen
#endif // EIGEN_SELFADJOINT_PACKED_PRODUCT_H
third_party/eigen/blas/PackedTriangularMatrixVector.h
Vendored
+82
View File
@@ -0,0 +1,82 @@
// 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 Eigen {
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 (!(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 (!(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;
}
};
};
} // namespace internal
} // namespace Eigen
#endif // EIGEN_PACKED_TRIANGULAR_MATRIX_VECTOR_H
third_party/eigen/blas/PackedTriangularSolverVector.h
Vendored
+76
View File
@@ -0,0 +1,76 @@
// 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 Eigen {
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);
}
};
} // namespace internal
} // namespace Eigen
#endif // EIGEN_PACKED_TRIANGULAR_SOLVER_VECTOR_H
third_party/eigen/blas/README.txt
Vendored
+6
View File
@@ -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.
third_party/eigen/blas/Rank2Update.h
Vendored
+56
View File
@@ -0,0 +1,56 @@
// 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 Eigen {
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);
}
}
};
} // namespace internal
} // namespace Eigen
#endif // EIGEN_RANK2UPDATE_H
third_party/eigen/blas/blas.h
Vendored
+484
View File
@@ -0,0 +1,484 @@
#ifndef BLAS_H
#define BLAS_H
#ifdef __cplusplus
extern "C" {
#endif
#define BLASFUNC(FUNC) FUNC##_
#ifdef __WIN64__
typedef long long BLASLONG;
typedef unsigned long long BLASULONG;
#else
typedef long BLASLONG;
typedef unsigned long BLASULONG;
#endif
void BLASFUNC(xerbla)(const char *, int *info);
float BLASFUNC(sdot)(int *, float *, int *, float *, int *);
float BLASFUNC(sdsdot)(int *, float *, float *, int *, float *, int *);
double BLASFUNC(dsdot)(int *, float *, int *, float *, int *);
double BLASFUNC(ddot)(int *, double *, int *, double *, int *);
double BLASFUNC(qdot)(int *, double *, int *, double *, int *);
void BLASFUNC(cdotuw)(int *, float *, int *, float *, int *, float *);
void BLASFUNC(cdotcw)(int *, float *, int *, float *, int *, float *);
void BLASFUNC(zdotuw)(int *, double *, int *, double *, int *, double *);
void BLASFUNC(zdotcw)(int *, double *, int *, double *, int *, double *);
void BLASFUNC(saxpy)(const int *, const float *, const float *, const int *, float *, const int *);
void BLASFUNC(daxpy)(const int *, const double *, const double *, const int *, double *, const int *);
void BLASFUNC(qaxpy)(const int *, const double *, const double *, const int *, double *, const int *);
void BLASFUNC(caxpy)(const int *, const float *, const float *, const int *, float *, const int *);
void BLASFUNC(zaxpy)(const int *, const double *, const double *, const int *, double *, const int *);
void BLASFUNC(xaxpy)(const int *, const double *, const double *, const int *, double *, const int *);
void BLASFUNC(caxpyc)(const int *, const float *, const float *, const int *, float *, const int *);
void BLASFUNC(zaxpyc)(const int *, const double *, const double *, const int *, double *, const int *);
void BLASFUNC(xaxpyc)(const int *, const double *, const double *, const int *, double *, const int *);
void BLASFUNC(scopy)(int *, float *, int *, float *, int *);
void BLASFUNC(dcopy)(int *, double *, int *, double *, int *);
void BLASFUNC(qcopy)(int *, double *, int *, double *, int *);
void BLASFUNC(ccopy)(int *, float *, int *, float *, int *);
void BLASFUNC(zcopy)(int *, double *, int *, double *, int *);
void BLASFUNC(xcopy)(int *, double *, int *, double *, int *);
void BLASFUNC(sswap)(int *, float *, int *, float *, int *);
void BLASFUNC(dswap)(int *, double *, int *, double *, int *);
void BLASFUNC(qswap)(int *, double *, int *, double *, int *);
void BLASFUNC(cswap)(int *, float *, int *, float *, int *);
void BLASFUNC(zswap)(int *, double *, int *, double *, int *);
void BLASFUNC(xswap)(int *, double *, int *, double *, int *);
float BLASFUNC(sasum)(int *, float *, int *);
float BLASFUNC(scasum)(int *, float *, int *);
double BLASFUNC(dasum)(int *, double *, int *);
double BLASFUNC(qasum)(int *, double *, int *);
double BLASFUNC(dzasum)(int *, double *, int *);
double BLASFUNC(qxasum)(int *, double *, int *);
int BLASFUNC(isamax)(int *, float *, int *);
int BLASFUNC(idamax)(int *, double *, int *);
int BLASFUNC(iqamax)(int *, double *, int *);
int BLASFUNC(icamax)(int *, float *, int *);
int BLASFUNC(izamax)(int *, double *, int *);
int BLASFUNC(ixamax)(int *, double *, int *);
int BLASFUNC(ismax)(int *, float *, int *);
int BLASFUNC(idmax)(int *, double *, int *);
int BLASFUNC(iqmax)(int *, double *, int *);
int BLASFUNC(icmax)(int *, float *, int *);
int BLASFUNC(izmax)(int *, double *, int *);
int BLASFUNC(ixmax)(int *, double *, int *);
int BLASFUNC(isamin)(int *, float *, int *);
int BLASFUNC(idamin)(int *, double *, int *);
int BLASFUNC(iqamin)(int *, double *, int *);
int BLASFUNC(icamin)(int *, float *, int *);
int BLASFUNC(izamin)(int *, double *, int *);
int BLASFUNC(ixamin)(int *, double *, int *);
int BLASFUNC(ismin)(int *, float *, int *);
int BLASFUNC(idmin)(int *, double *, int *);
int BLASFUNC(iqmin)(int *, double *, int *);
int BLASFUNC(icmin)(int *, float *, int *);
int BLASFUNC(izmin)(int *, double *, int *);
int BLASFUNC(ixmin)(int *, double *, int *);
float BLASFUNC(samax)(int *, float *, int *);
double BLASFUNC(damax)(int *, double *, int *);
double BLASFUNC(qamax)(int *, double *, int *);
float BLASFUNC(scamax)(int *, float *, int *);
double BLASFUNC(dzamax)(int *, double *, int *);
double BLASFUNC(qxamax)(int *, double *, int *);
float BLASFUNC(samin)(int *, float *, int *);
double BLASFUNC(damin)(int *, double *, int *);
double BLASFUNC(qamin)(int *, double *, int *);
float BLASFUNC(scamin)(int *, float *, int *);
double BLASFUNC(dzamin)(int *, double *, int *);
double BLASFUNC(qxamin)(int *, double *, int *);
float BLASFUNC(smax)(int *, float *, int *);
double BLASFUNC(dmax)(int *, double *, int *);
double BLASFUNC(qmax)(int *, double *, int *);
float BLASFUNC(scmax)(int *, float *, int *);
double BLASFUNC(dzmax)(int *, double *, int *);
double BLASFUNC(qxmax)(int *, double *, int *);
float BLASFUNC(smin)(int *, float *, int *);
double BLASFUNC(dmin)(int *, double *, int *);
double BLASFUNC(qmin)(int *, double *, int *);
float BLASFUNC(scmin)(int *, float *, int *);
double BLASFUNC(dzmin)(int *, double *, int *);
double BLASFUNC(qxmin)(int *, double *, int *);
void BLASFUNC(sscal)(int *, float *, float *, int *);
void BLASFUNC(dscal)(int *, double *, double *, int *);
void BLASFUNC(qscal)(int *, double *, double *, int *);
void BLASFUNC(cscal)(int *, float *, float *, int *);
void BLASFUNC(zscal)(int *, double *, double *, int *);
void BLASFUNC(xscal)(int *, double *, double *, int *);
void BLASFUNC(csscal)(int *, float *, float *, int *);
void BLASFUNC(zdscal)(int *, double *, double *, int *);
void BLASFUNC(xqscal)(int *, double *, double *, int *);
float BLASFUNC(snrm2)(int *, float *, int *);
float BLASFUNC(scnrm2)(int *, float *, int *);
double BLASFUNC(dnrm2)(int *, double *, int *);
double BLASFUNC(qnrm2)(int *, double *, int *);
double BLASFUNC(dznrm2)(int *, double *, int *);
double BLASFUNC(qxnrm2)(int *, double *, int *);
void BLASFUNC(srot)(int *, float *, int *, float *, int *, float *, float *);
void BLASFUNC(drot)(int *, double *, int *, double *, int *, double *, double *);
void BLASFUNC(qrot)(int *, double *, int *, double *, int *, double *, double *);
void BLASFUNC(csrot)(int *, float *, int *, float *, int *, float *, float *);
void BLASFUNC(zdrot)(int *, double *, int *, double *, int *, double *, double *);
void BLASFUNC(xqrot)(int *, double *, int *, double *, int *, double *, double *);
void BLASFUNC(srotg)(float *, float *, float *, float *);
void BLASFUNC(drotg)(double *, double *, double *, double *);
void BLASFUNC(qrotg)(double *, double *, double *, double *);
void BLASFUNC(crotg)(float *, float *, float *, float *);
void BLASFUNC(zrotg)(double *, double *, double *, double *);
void BLASFUNC(xrotg)(double *, double *, double *, double *);
void BLASFUNC(srotmg)(float *, float *, float *, float *, float *);
void BLASFUNC(drotmg)(double *, double *, double *, double *, double *);
void BLASFUNC(srotm)(int *, float *, int *, float *, int *, float *);
void BLASFUNC(drotm)(int *, double *, int *, double *, int *, double *);
void BLASFUNC(qrotm)(int *, double *, int *, double *, int *, double *);
/* Level 2 routines */
void BLASFUNC(sger)(int *, int *, float *, float *, int *, float *, int *, float *, int *);
void BLASFUNC(dger)(int *, int *, double *, double *, int *, double *, int *, double *, int *);
void BLASFUNC(qger)(int *, int *, double *, double *, int *, double *, int *, double *, int *);
void BLASFUNC(cgeru)(int *, int *, float *, float *, int *, float *, int *, float *, int *);
void BLASFUNC(cgerc)(int *, int *, float *, float *, int *, float *, int *, float *, int *);
void BLASFUNC(zgeru)(int *, int *, double *, double *, int *, double *, int *, double *, int *);
void BLASFUNC(zgerc)(int *, int *, double *, double *, int *, double *, int *, double *, int *);
void BLASFUNC(xgeru)(int *, int *, double *, double *, int *, double *, int *, double *, int *);
void BLASFUNC(xgerc)(int *, int *, double *, double *, int *, double *, int *, double *, int *);
void BLASFUNC(sgemv)(const char *, const int *, const int *, const float *, const float *, const int *, const float *,
const int *, const float *, float *, const int *);
void BLASFUNC(dgemv)(const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(qgemv)(const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(cgemv)(const char *, const int *, const int *, const float *, const float *, const int *, const float *,
const int *, const float *, float *, const int *);
void BLASFUNC(zgemv)(const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(xgemv)(const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(strsv)(const char *, const char *, const char *, const int *, const float *, const int *, float *,
const int *);
void BLASFUNC(dtrsv)(const char *, const char *, const char *, const int *, const double *, const int *, double *,
const int *);
void BLASFUNC(qtrsv)(const char *, const char *, const char *, const int *, const double *, const int *, double *,
const int *);
void BLASFUNC(ctrsv)(const char *, const char *, const char *, const int *, const float *, const int *, float *,
const int *);
void BLASFUNC(ztrsv)(const char *, const char *, const char *, const int *, const double *, const int *, double *,
const int *);
void BLASFUNC(xtrsv)(const char *, const char *, const char *, const int *, const double *, const int *, double *,
const int *);
void BLASFUNC(stpsv)(char *, char *, char *, int *, float *, float *, int *);
void BLASFUNC(dtpsv)(char *, char *, char *, int *, double *, double *, int *);
void BLASFUNC(qtpsv)(char *, char *, char *, int *, double *, double *, int *);
void BLASFUNC(ctpsv)(char *, char *, char *, int *, float *, float *, int *);
void BLASFUNC(ztpsv)(char *, char *, char *, int *, double *, double *, int *);
void BLASFUNC(xtpsv)(char *, char *, char *, int *, double *, double *, int *);
void BLASFUNC(strmv)(const char *, const char *, const char *, const int *, const float *, const int *, float *,
const int *);
void BLASFUNC(dtrmv)(const char *, const char *, const char *, const int *, const double *, const int *, double *,
const int *);
void BLASFUNC(qtrmv)(const char *, const char *, const char *, const int *, const double *, const int *, double *,
const int *);
void BLASFUNC(ctrmv)(const char *, const char *, const char *, const int *, const float *, const int *, float *,
const int *);
void BLASFUNC(ztrmv)(const char *, const char *, const char *, const int *, const double *, const int *, double *,
const int *);
void BLASFUNC(xtrmv)(const char *, const char *, const char *, const int *, const double *, const int *, double *,
const int *);
void BLASFUNC(stpmv)(char *, char *, char *, int *, float *, float *, int *);
void BLASFUNC(dtpmv)(char *, char *, char *, int *, double *, double *, int *);
void BLASFUNC(qtpmv)(char *, char *, char *, int *, double *, double *, int *);
void BLASFUNC(ctpmv)(char *, char *, char *, int *, float *, float *, int *);
void BLASFUNC(ztpmv)(char *, char *, char *, int *, double *, double *, int *);
void BLASFUNC(xtpmv)(char *, char *, char *, int *, double *, double *, int *);
void BLASFUNC(stbmv)(char *, char *, char *, int *, int *, float *, int *, float *, int *);
void BLASFUNC(dtbmv)(char *, char *, char *, int *, int *, double *, int *, double *, int *);
void BLASFUNC(qtbmv)(char *, char *, char *, int *, int *, double *, int *, double *, int *);
void BLASFUNC(ctbmv)(char *, char *, char *, int *, int *, float *, int *, float *, int *);
void BLASFUNC(ztbmv)(char *, char *, char *, int *, int *, double *, int *, double *, int *);
void BLASFUNC(xtbmv)(char *, char *, char *, int *, int *, double *, int *, double *, int *);
void BLASFUNC(stbsv)(char *, char *, char *, int *, int *, float *, int *, float *, int *);
void BLASFUNC(dtbsv)(char *, char *, char *, int *, int *, double *, int *, double *, int *);
void BLASFUNC(qtbsv)(char *, char *, char *, int *, int *, double *, int *, double *, int *);
void BLASFUNC(ctbsv)(char *, char *, char *, int *, int *, float *, int *, float *, int *);
void BLASFUNC(ztbsv)(char *, char *, char *, int *, int *, double *, int *, double *, int *);
void BLASFUNC(xtbsv)(char *, char *, char *, int *, int *, double *, int *, double *, int *);
void BLASFUNC(ssymv)(const char *, const int *, const float *, const float *, const int *, const float *, const int *,
const float *, float *, const int *);
void BLASFUNC(dsymv)(const char *, const int *, const double *, const double *, const int *, const double *,
const int *, const double *, double *, const int *);
void BLASFUNC(qsymv)(const char *, const int *, const double *, const double *, const int *, const double *,
const int *, const double *, double *, const int *);
void BLASFUNC(sspmv)(char *, int *, float *, float *, float *, int *, float *, float *, int *);
void BLASFUNC(dspmv)(char *, int *, double *, double *, double *, int *, double *, double *, int *);
void BLASFUNC(qspmv)(char *, int *, double *, double *, double *, int *, double *, double *, int *);
void BLASFUNC(ssyr)(const char *, const int *, const float *, const float *, const int *, float *, const int *);
void BLASFUNC(dsyr)(const char *, const int *, const double *, const double *, const int *, double *, const int *);
void BLASFUNC(qsyr)(const char *, const int *, const double *, const double *, const int *, double *, const int *);
void BLASFUNC(ssyr2)(const char *, const int *, const float *, const float *, const int *, const float *, const int *,
float *, const int *);
void BLASFUNC(dsyr2)(const char *, const int *, const double *, const double *, const int *, const double *,
const int *, double *, const int *);
void BLASFUNC(qsyr2)(const char *, const int *, const double *, const double *, const int *, const double *,
const int *, double *, const int *);
void BLASFUNC(csyr2)(const char *, const int *, const float *, const float *, const int *, const float *, const int *,
float *, const int *);
void BLASFUNC(zsyr2)(const char *, const int *, const double *, const double *, const int *, const double *,
const int *, double *, const int *);
void BLASFUNC(xsyr2)(const char *, const int *, const double *, const double *, const int *, const double *,
const int *, double *, const int *);
void BLASFUNC(sspr)(char *, int *, float *, float *, int *, float *);
void BLASFUNC(dspr)(char *, int *, double *, double *, int *, double *);
void BLASFUNC(qspr)(char *, int *, double *, double *, int *, double *);
void BLASFUNC(sspr2)(char *, int *, float *, float *, int *, float *, int *, float *);
void BLASFUNC(dspr2)(char *, int *, double *, double *, int *, double *, int *, double *);
void BLASFUNC(qspr2)(char *, int *, double *, double *, int *, double *, int *, double *);
void BLASFUNC(cspr2)(char *, int *, float *, float *, int *, float *, int *, float *);
void BLASFUNC(zspr2)(char *, int *, double *, double *, int *, double *, int *, double *);
void BLASFUNC(xspr2)(char *, int *, double *, double *, int *, double *, int *, double *);
void BLASFUNC(cher)(char *, int *, float *, float *, int *, float *, int *);
void BLASFUNC(zher)(char *, int *, double *, double *, int *, double *, int *);
void BLASFUNC(xher)(char *, int *, double *, double *, int *, double *, int *);
void BLASFUNC(chpr)(char *, int *, float *, float *, int *, float *);
void BLASFUNC(zhpr)(char *, int *, double *, double *, int *, double *);
void BLASFUNC(xhpr)(char *, int *, double *, double *, int *, double *);
void BLASFUNC(cher2)(char *, int *, float *, float *, int *, float *, int *, float *, int *);
void BLASFUNC(zher2)(char *, int *, double *, double *, int *, double *, int *, double *, int *);
void BLASFUNC(xher2)(char *, int *, double *, double *, int *, double *, int *, double *, int *);
void BLASFUNC(chpr2)(char *, int *, float *, float *, int *, float *, int *, float *);
void BLASFUNC(zhpr2)(char *, int *, double *, double *, int *, double *, int *, double *);
void BLASFUNC(xhpr2)(char *, int *, double *, double *, int *, double *, int *, double *);
void BLASFUNC(chemv)(const char *, const int *, const float *, const float *, const int *, const float *, const int *,
const float *, float *, const int *);
void BLASFUNC(zhemv)(const char *, const int *, const double *, const double *, const int *, const double *,
const int *, const double *, double *, const int *);
void BLASFUNC(xhemv)(const char *, const int *, const double *, const double *, const int *, const double *,
const int *, const double *, double *, const int *);
void BLASFUNC(chpmv)(char *, int *, float *, float *, float *, int *, float *, float *, int *);
void BLASFUNC(zhpmv)(char *, int *, double *, double *, double *, int *, double *, double *, int *);
void BLASFUNC(xhpmv)(char *, int *, double *, double *, double *, int *, double *, double *, int *);
void BLASFUNC(snorm)(char *, int *, int *, float *, int *);
void BLASFUNC(dnorm)(char *, int *, int *, double *, int *);
void BLASFUNC(cnorm)(char *, int *, int *, float *, int *);
void BLASFUNC(znorm)(char *, int *, int *, double *, int *);
void BLASFUNC(sgbmv)(char *, int *, int *, int *, int *, float *, float *, int *, float *, int *, float *, float *,
int *);
void BLASFUNC(dgbmv)(char *, int *, int *, int *, int *, double *, double *, int *, double *, int *, double *, double *,
int *);
void BLASFUNC(qgbmv)(char *, int *, int *, int *, int *, double *, double *, int *, double *, int *, double *, double *,
int *);
void BLASFUNC(cgbmv)(char *, int *, int *, int *, int *, float *, float *, int *, float *, int *, float *, float *,
int *);
void BLASFUNC(zgbmv)(char *, int *, int *, int *, int *, double *, double *, int *, double *, int *, double *, double *,
int *);
void BLASFUNC(xgbmv)(char *, int *, int *, int *, int *, double *, double *, int *, double *, int *, double *, double *,
int *);
void BLASFUNC(ssbmv)(char *, int *, int *, float *, float *, int *, float *, int *, float *, float *, int *);
void BLASFUNC(dsbmv)(char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *);
void BLASFUNC(qsbmv)(char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *);
void BLASFUNC(csbmv)(char *, int *, int *, float *, float *, int *, float *, int *, float *, float *, int *);
void BLASFUNC(zsbmv)(char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *);
void BLASFUNC(xsbmv)(char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *);
void BLASFUNC(chbmv)(char *, int *, int *, float *, float *, int *, float *, int *, float *, float *, int *);
void BLASFUNC(zhbmv)(char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *);
void BLASFUNC(xhbmv)(char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *);
/* Level 3 routines */
void BLASFUNC(sgemm)(const char *, const char *, const int *, const int *, const int *, const float *, const float *,
const int *, const float *, const int *, const float *, float *, const int *);
void BLASFUNC(dgemm)(const char *, const char *, const int *, const int *, const int *, const double *, const double *,
const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(qgemm)(const char *, const char *, const int *, const int *, const int *, const double *, const double *,
const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(cgemm)(const char *, const char *, const int *, const int *, const int *, const float *, const float *,
const int *, const float *, const int *, const float *, float *, const int *);
void BLASFUNC(zgemm)(const char *, const char *, const int *, const int *, const int *, const double *, const double *,
const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(xgemm)(const char *, const char *, const int *, const int *, const int *, const double *, const double *,
const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(cgemm3m)(char *, char *, int *, int *, int *, float *, float *, int *, float *, int *, float *, float *,
int *);
void BLASFUNC(zgemm3m)(char *, char *, int *, int *, int *, double *, double *, int *, double *, int *, double *,
double *, int *);
void BLASFUNC(xgemm3m)(char *, char *, int *, int *, int *, double *, double *, int *, double *, int *, double *,
double *, int *);
void BLASFUNC(sge2mm)(char *, char *, char *, int *, int *, float *, float *, int *, float *, int *, float *, float *,
int *);
void BLASFUNC(dge2mm)(char *, char *, char *, int *, int *, double *, double *, int *, double *, int *, double *,
double *, int *);
void BLASFUNC(cge2mm)(char *, char *, char *, int *, int *, float *, float *, int *, float *, int *, float *, float *,
int *);
void BLASFUNC(zge2mm)(char *, char *, char *, int *, int *, double *, double *, int *, double *, int *, double *,
double *, int *);
void BLASFUNC(strsm)(const char *, const char *, const char *, const char *, const int *, const int *, const float *,
const float *, const int *, float *, const int *);
void BLASFUNC(dtrsm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, double *, const int *);
void BLASFUNC(qtrsm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, double *, const int *);
void BLASFUNC(ctrsm)(const char *, const char *, const char *, const char *, const int *, const int *, const float *,
const float *, const int *, float *, const int *);
void BLASFUNC(ztrsm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, double *, const int *);
void BLASFUNC(xtrsm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, double *, const int *);
void BLASFUNC(strmm)(const char *, const char *, const char *, const char *, const int *, const int *, const float *,
const float *, const int *, float *, const int *);
void BLASFUNC(dtrmm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, double *, const int *);
void BLASFUNC(qtrmm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, double *, const int *);
void BLASFUNC(ctrmm)(const char *, const char *, const char *, const char *, const int *, const int *, const float *,
const float *, const int *, float *, const int *);
void BLASFUNC(ztrmm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, double *, const int *);
void BLASFUNC(xtrmm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, double *, const int *);
void BLASFUNC(ssymm)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, const int *, const float *, float *, const int *);
void BLASFUNC(dsymm)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(qsymm)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(csymm)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, const int *, const float *, float *, const int *);
void BLASFUNC(zsymm)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(xsymm)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(csymm3m)(char *, char *, int *, int *, float *, float *, int *, float *, int *, float *, float *, int *);
void BLASFUNC(zsymm3m)(char *, char *, int *, int *, double *, double *, int *, double *, int *, double *, double *,
int *);
void BLASFUNC(xsymm3m)(char *, char *, int *, int *, double *, double *, int *, double *, int *, double *, double *,
int *);
void BLASFUNC(ssyrk)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, float *, const int *);
void BLASFUNC(dsyrk)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, double *, const int *);
void BLASFUNC(qsyrk)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, double *, const int *);
void BLASFUNC(csyrk)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, float *, const int *);
void BLASFUNC(zsyrk)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, double *, const int *);
void BLASFUNC(xsyrk)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, double *, const int *);
void BLASFUNC(ssyr2k)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, const int *, const float *, float *, const int *);
void BLASFUNC(dsyr2k)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(qsyr2k)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(csyr2k)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, const int *, const float *, float *, const int *);
void BLASFUNC(zsyr2k)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(xsyr2k)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(chemm)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, const int *, const float *, float *, const int *);
void BLASFUNC(zhemm)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(xhemm)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(chemm3m)(char *, char *, int *, int *, float *, float *, int *, float *, int *, float *, float *, int *);
void BLASFUNC(zhemm3m)(char *, char *, int *, int *, double *, double *, int *, double *, int *, double *, double *,
int *);
void BLASFUNC(xhemm3m)(char *, char *, int *, int *, double *, double *, int *, double *, int *, double *, double *,
int *);
void BLASFUNC(cherk)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, float *, const int *);
void BLASFUNC(zherk)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, double *, const int *);
void BLASFUNC(xherk)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, double *, const int *);
void BLASFUNC(cher2k)(const char *, const char *, const int *, const int *, const float *, const float *, const int *,
const float *, const int *, const float *, float *, const int *);
void BLASFUNC(zher2k)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(xher2k)(const char *, const char *, const int *, const int *, const double *, const double *, const int *,
const double *, const int *, const double *, double *, const int *);
void BLASFUNC(cher2m)(const char *, const char *, const char *, const int *, const int *, const float *, const float *,
const int *, const float *, const int *, const float *, float *, const int *);
void BLASFUNC(zher2m)(const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(xher2m)(const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(sgemmtr)(const char *, const char *, const char *, const int *, const int *, const float *, const float *,
const int *, const float *, const int *, const float *, float *, const int *);
void BLASFUNC(dgemmtr)(const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(qgemmtr)(const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(cgemmtr)(const char *, const char *, const char *, const int *, const int *, const float *, const float *,
const int *, const float *, const int *, const float *, float *, const int *);
void BLASFUNC(zgemmtr)(const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, const double *, const int *, const double *, double *, const int *);
void BLASFUNC(xgemmtr)(const char *, const char *, const char *, const int *, const int *, const double *,
const double *, const int *, const double *, const int *, const double *, double *, const int *);
#ifdef __cplusplus
}
#endif
#endif
third_party/eigen/blas/common.h
Vendored
+153
View File
@@ -0,0 +1,153 @@
// 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
#ifdef __GNUC__
#if __GNUC__ < 5
// GCC < 5.0 does not like the global Scalar typedef
// we just keep shadow-warnings disabled permanently
#define EIGEN_PERMANENTLY_DISABLE_STUPID_WARNINGS
#endif
#endif
#include "../Eigen/Core"
#include "../Eigen/Jacobi"
#include <complex>
#ifndef SCALAR
#error the token SCALAR must be defined to compile this file
#endif
#include "blas.h"
#include "BandTriangularSolver.h"
#include "GeneralRank1Update.h"
#include "PackedSelfadjointProduct.h"
#include "PackedTriangularMatrixVector.h"
#include "PackedTriangularSolverVector.h"
#include "Rank2Update.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; }
typedef SCALAR Scalar;
typedef Eigen::NumTraits<Scalar>::Real RealScalar;
typedef std::complex<RealScalar> Complex;
enum { IsComplex = Eigen::NumTraits<SCALAR>::IsComplex, Conj = IsComplex };
typedef Eigen::Matrix<Scalar, Eigen::Dynamic, Eigen::Dynamic, Eigen::ColMajor> PlainMatrixType;
typedef Eigen::Map<Eigen::Matrix<Scalar, Eigen::Dynamic, Eigen::Dynamic, Eigen::ColMajor>, 0, Eigen::OuterStride<> >
MatrixType;
typedef Eigen::Map<const Eigen::Matrix<Scalar, Eigen::Dynamic, Eigen::Dynamic, Eigen::ColMajor>, 0,
Eigen::OuterStride<> >
ConstMatrixType;
typedef Eigen::Map<Eigen::Matrix<Scalar, Eigen::Dynamic, 1>, 0, Eigen::InnerStride<Eigen::Dynamic> > StridedVectorType;
typedef Eigen::Map<Eigen::Matrix<Scalar, Eigen::Dynamic, 1> > CompactVectorType;
template <typename T>
Eigen::Map<Eigen::Matrix<T, Eigen::Dynamic, Eigen::Dynamic, Eigen::ColMajor>, 0, Eigen::OuterStride<> > matrix(
T* data, int rows, int cols, int stride) {
return Eigen::Map<Eigen::Matrix<T, Eigen::Dynamic, Eigen::Dynamic, Eigen::ColMajor>, 0, Eigen::OuterStride<> >(
data, rows, cols, Eigen::OuterStride<>(stride));
}
template <typename T>
Eigen::Map<const Eigen::Matrix<T, Eigen::Dynamic, Eigen::Dynamic, Eigen::ColMajor>, 0, Eigen::OuterStride<> > matrix(
const T* data, int rows, int cols, int stride) {
return Eigen::Map<const Eigen::Matrix<T, Eigen::Dynamic, Eigen::Dynamic, Eigen::ColMajor>, 0, Eigen::OuterStride<> >(
data, rows, cols, Eigen::OuterStride<>(stride));
}
template <typename T>
Eigen::Map<Eigen::Matrix<T, Eigen::Dynamic, 1>, 0, Eigen::InnerStride<Eigen::Dynamic> > make_vector(T* data, int size,
int incr) {
return Eigen::Map<Eigen::Matrix<T, Eigen::Dynamic, 1>, 0, Eigen::InnerStride<Eigen::Dynamic> >(
data, size, Eigen::InnerStride<Eigen::Dynamic>(incr));
}
template <typename T>
Eigen::Map<const Eigen::Matrix<T, Eigen::Dynamic, 1>, 0, Eigen::InnerStride<Eigen::Dynamic> > make_vector(const T* data,
int size,
int incr) {
return Eigen::Map<const Eigen::Matrix<T, Eigen::Dynamic, 1>, 0, Eigen::InnerStride<Eigen::Dynamic> >(
data, size, Eigen::InnerStride<Eigen::Dynamic>(incr));
}
template <typename T>
Eigen::Map<Eigen::Matrix<T, Eigen::Dynamic, 1> > make_vector(T* data, int size) {
return Eigen::Map<Eigen::Matrix<T, Eigen::Dynamic, 1> >(data, size);
}
template <typename T>
Eigen::Map<const Eigen::Matrix<T, Eigen::Dynamic, 1> > make_vector(const T* data, int size) {
return Eigen::Map<const Eigen::Matrix<T, Eigen::Dynamic, 1> >(data, size);
}
template <typename T>
T* get_compact_vector(T* x, int n, int incx) {
if (incx == 1) return x;
std::remove_const_t<T>* 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;
}
#ifndef EIGEN_BLAS_FUNC_SUFFIX
#define EIGEN_BLAS_FUNC_SUFFIX _
#endif
#define EIGEN_BLAS_FUNC_NAME(X) EIGEN_CAT(SCALAR_SUFFIX, EIGEN_CAT(X, EIGEN_BLAS_FUNC_SUFFIX))
#define EIGEN_BLAS_FUNC(X) extern "C" void EIGEN_BLAS_FUNC_NAME(X)
#endif // EIGEN_BLAS_COMMON_H
third_party/eigen/blas/complex_double.cpp
Vendored
+20
View File
@@ -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"
third_party/eigen/blas/complex_single.cpp
Vendored
+20
View File
@@ -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"
third_party/eigen/blas/double.cpp
Vendored
+43
View File
@@ -0,0 +1,43 @@
// 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"
extern "C" double EIGEN_BLAS_FUNC_NAME(sdot)(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;
}
third_party/eigen/blas/f2c/chbmv.c
Vendored
+456
View File
@@ -0,0 +1,456 @@
/* 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"
static inline void r_cnjg(complex *r, complex *z) {
r->r = z->r;
r->i = -(z->i);
}
/* Subroutine */ void chbmv_(char *uplo, integer *n, integer *k, complex *alpha, complex *a, integer *lda, complex *x,
integer *incx, complex *beta, complex *y, integer *incy) {
/* 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;
/* Local variables */
integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
complex temp1, temp2;
extern logical lsame_(char *, char *);
integer kplus1;
extern /* Subroutine */ void xerbla_(const char *, integer *);
/* .. 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") && !lsame_(uplo, "L")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && beta->i == 0.f))) {
return;
}
/* 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;
}
if (lsame_(uplo, "U")) {
/* 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: */
}
}
}
/* End of CHBMV . */
} /* chbmv_ */
third_party/eigen/blas/f2c/chpmv.c
Vendored
+407
View File
@@ -0,0 +1,407 @@
/* 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"
static inline void r_cnjg(complex *r, complex *z) {
r->r = z->r;
r->i = -(z->i);
}
/* Subroutine */ void chpmv_(char *uplo, integer *n, complex *alpha, complex *ap, complex *x, integer *incx,
complex *beta, complex *y, integer *incy) {
/* 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;
/* Local variables */
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
complex temp1, temp2;
extern logical lsame_(char *, char *);
extern /* Subroutine */ void xerbla_(const char *, integer *);
/* .. 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") && !lsame_(uplo, "L")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && beta->i == 0.f))) {
return;
}
/* 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;
}
kk = 1;
if (lsame_(uplo, "U")) {
/* 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: */
}
}
}
/* End of CHPMV . */
} /* chpmv_ */
third_party/eigen/blas/f2c/complexdots.c
Vendored
+73
View File
@@ -0,0 +1,73 @@
/* 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 */ void 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 */ void 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 */ void 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 */ void 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_ */
third_party/eigen/blas/f2c/ctbmv.c
Vendored
+586
View File
@@ -0,0 +1,586 @@
/* 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"
static inline void r_cnjg(complex *r, complex *z) {
r->r = z->r;
r->i = -(z->i);
}
/* Subroutine */ void ctbmv_(char *uplo, char *trans, char *diag, integer *n, integer *k, complex *a, integer *lda,
complex *x, integer *incx) {
/* 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;
/* Local variables */
integer i__, j, l, ix, jx, kx, info;
complex temp;
extern logical lsame_(char *, char *);
integer kplus1;
extern /* Subroutine */ void xerbla_(const char *, integer *);
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 */
/* transformed 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") && !lsame_(uplo, "L")) {
info = 1;
} else if (!lsame_(trans, "N") && !lsame_(trans, "T") && !lsame_(trans, "C")) {
info = 2;
} else if (!lsame_(diag, "U") && !lsame_(diag, "N")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0) {
return;
}
noconj = lsame_(trans, "T");
nounit = lsame_(diag, "N");
/* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 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")) {
/* Form x := A*x. */
if (lsame_(uplo, "U")) {
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")) {
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: */
}
}
}
}
/* End of CTBMV . */
} /* ctbmv_ */
third_party/eigen/blas/f2c/datatypes.h
Vendored
+27
View File
@@ -0,0 +1,27 @@
/* 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 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
third_party/eigen/blas/f2c/drotm.c
Vendored
+213
View File
@@ -0,0 +1,213 @@
/* 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 */ void 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;
} /* drotm_ */
third_party/eigen/blas/f2c/drotmg.c
Vendored
+293
View File
@@ -0,0 +1,293 @@
/* drotmg.f -- translated by f2c (version 20100827).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#include "datatypes.h"
/* Subroutine */ void 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;
(void)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;
} /* drotmg_ */
third_party/eigen/blas/f2c/dsbmv.c
Vendored
+356
View File
@@ -0,0 +1,356 @@
/* 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 */ void dsbmv_(char *uplo, integer *n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy) {
/* 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 *);
integer kplus1;
extern /* Subroutine */ void xerbla_(const char *, integer *);
/* .. 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") && !lsame_(uplo, "L")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
return;
}
/* 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;
}
if (lsame_(uplo, "U")) {
/* 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: */
}
}
}
/* End of DSBMV . */
} /* dsbmv_ */
third_party/eigen/blas/f2c/dspmv.c
Vendored
+308
View File
@@ -0,0 +1,308 @@
/* 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 */ void dspmv_(char *uplo, integer *n, doublereal *alpha, doublereal *ap, doublereal *x, integer *incx,
doublereal *beta, doublereal *y, integer *incy) {
/* 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 *);
extern /* Subroutine */ void xerbla_(const char *, integer *);
/* .. 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") && !lsame_(uplo, "L")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0. && *beta == 1.)) {
return;
}
/* 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;
}
kk = 1;
if (lsame_(uplo, "U")) {
/* 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: */
}
}
}
/* End of DSPMV . */
} /* dspmv_ */
third_party/eigen/blas/f2c/dtbmv.c
Vendored
+417
View File
@@ -0,0 +1,417 @@
/* 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 */ void dtbmv_(char *uplo, char *trans, char *diag, integer *n, integer *k, doublereal *a, integer *lda,
doublereal *x, integer *incx) {
/* 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 *);
integer kplus1;
extern /* Subroutine */ void xerbla_(const char *, integer *);
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 */
/* transformed 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") && !lsame_(uplo, "L")) {
info = 1;
} else if (!lsame_(trans, "N") && !lsame_(trans, "T") && !lsame_(trans, "C")) {
info = 2;
} else if (!lsame_(diag, "U") && !lsame_(diag, "N")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0) {
return;
}
nounit = lsame_(diag, "N");
/* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 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")) {
/* Form x := A*x. */
if (lsame_(uplo, "U")) {
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")) {
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: */
}
}
}
}
/* End of DTBMV . */
} /* dtbmv_ */
third_party/eigen/blas/f2c/lsame.c
Vendored
+109
View File
@@ -0,0 +1,109 @@
/* 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) {
/* 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_ */
third_party/eigen/blas/f2c/srotm.c
Vendored
+212
View File
@@ -0,0 +1,212 @@
/* 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 */ void 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;
} /* srotm_ */
third_party/eigen/blas/f2c/srotmg.c
Vendored
+293
View File
@@ -0,0 +1,293 @@
/* 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 */ void 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;
(void)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;
} /* srotmg_ */
third_party/eigen/blas/f2c/ssbmv.c
Vendored
+359
View File
@@ -0,0 +1,359 @@
/* 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 */ void ssbmv_(char *uplo, integer *n, integer *k, real *alpha, real *a, integer *lda, real *x,
integer *incx, real *beta, real *y, integer *incy) {
/* 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 *);
integer kplus1;
extern /* Subroutine */ void xerbla_(const char *, integer *);
/* .. 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") && !lsame_(uplo, "L")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
return;
}
/* 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;
}
if (lsame_(uplo, "U")) {
/* 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: */
}
}
}
/* End of SSBMV . */
} /* ssbmv_ */
third_party/eigen/blas/f2c/sspmv.c
Vendored
+308
View File
@@ -0,0 +1,308 @@
/* 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 */ void sspmv_(char *uplo, integer *n, real *alpha, real *ap, real *x, integer *incx, real *beta, real *y,
integer *incy) {
/* 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 *);
extern /* Subroutine */ void xerbla_(const char *, integer *);
/* .. 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") && !lsame_(uplo, "L")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) {
return;
}
/* 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;
}
kk = 1;
if (lsame_(uplo, "U")) {
/* 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: */
}
}
}
/* End of SSPMV . */
} /* sspmv_ */
third_party/eigen/blas/f2c/stbmv.c
Vendored
+417
View File
@@ -0,0 +1,417 @@
/* 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 */ void stbmv_(char *uplo, char *trans, char *diag, integer *n, integer *k, real *a, integer *lda,
real *x, integer *incx) {
/* 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 *);
integer kplus1;
extern /* Subroutine */ void xerbla_(const char *, integer *);
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 */
/* transformed 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") && !lsame_(uplo, "L")) {
info = 1;
} else if (!lsame_(trans, "N") && !lsame_(trans, "T") && !lsame_(trans, "C")) {
info = 2;
} else if (!lsame_(diag, "U") && !lsame_(diag, "N")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0) {
return;
}
nounit = lsame_(diag, "N");
/* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 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")) {
/* Form x := A*x. */
if (lsame_(uplo, "U")) {
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")) {
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: */
}
}
}
}
/* End of STBMV . */
} /* stbmv_ */
third_party/eigen/blas/f2c/zhbmv.c
Vendored
+456
View File
@@ -0,0 +1,456 @@
/* 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"
static inline void d_cnjg(doublecomplex *r, doublecomplex *z) {
r->r = z->r;
r->i = -(z->i);
}
/* Subroutine */ void zhbmv_(char *uplo, integer *n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda,
doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *incy) {
/* 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;
/* Local variables */
integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
doublecomplex temp1, temp2;
extern logical lsame_(char *, char *);
integer kplus1;
extern /* Subroutine */ void xerbla_(const char *, integer *);
/* .. 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") && !lsame_(uplo, "L")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.))) {
return;
}
/* 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;
}
if (lsame_(uplo, "U")) {
/* 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: */
}
}
}
/* End of ZHBMV . */
} /* zhbmv_ */
third_party/eigen/blas/f2c/zhpmv.c
Vendored
+407
View File
@@ -0,0 +1,407 @@
/* 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"
static inline void d_cnjg(doublecomplex *r, doublecomplex *z) {
r->r = z->r;
r->i = -(z->i);
}
/* Subroutine */ void zhpmv_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *ap, doublecomplex *x,
integer *incx, doublecomplex *beta, doublecomplex *y, integer *incy) {
/* 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;
/* Local variables */
integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
doublecomplex temp1, temp2;
extern logical lsame_(char *, char *);
extern /* Subroutine */ void xerbla_(const char *, integer *);
/* .. 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") && !lsame_(uplo, "L")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.))) {
return;
}
/* 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;
}
kk = 1;
if (lsame_(uplo, "U")) {
/* 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: */
}
}
}
/* End of ZHPMV . */
} /* zhpmv_ */
third_party/eigen/blas/f2c/ztbmv.c
Vendored
+586
View File
@@ -0,0 +1,586 @@
/* 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"
static inline void d_cnjg(doublecomplex *r, doublecomplex *z) {
r->r = z->r;
r->i = -(z->i);
}
/* Subroutine */ void ztbmv_(char *uplo, char *trans, char *diag, integer *n, integer *k, doublecomplex *a,
integer *lda, doublecomplex *x, integer *incx) {
/* 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;
/* Local variables */
integer i__, j, l, ix, jx, kx, info;
doublecomplex temp;
extern logical lsame_(char *, char *);
integer kplus1;
extern /* Subroutine */ void xerbla_(const char *, integer *);
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 */
/* transformed 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") && !lsame_(uplo, "L")) {
info = 1;
} else if (!lsame_(trans, "N") && !lsame_(trans, "T") && !lsame_(trans, "C")) {
info = 2;
} else if (!lsame_(diag, "U") && !lsame_(diag, "N")) {
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);
return;
}
/* Quick return if possible. */
if (*n == 0) {
return;
}
noconj = lsame_(trans, "T");
nounit = lsame_(diag, "N");
/* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 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")) {
/* Form x := A*x. */
if (lsame_(uplo, "U")) {
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")) {
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: */
}
}
}
}
/* End of ZTBMV . */
} /* ztbmv_ */
third_party/eigen/blas/level1_cplx_impl.h
Vendored
+159
View File
@@ -0,0 +1,159 @@
// 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;
inline RealScalar operator()(const Scalar &a) const { return Eigen::numext::norm1(a); }
};
namespace Eigen {
namespace internal {
template <>
struct functor_traits<scalar_norm1_op> {
enum { Cost = 3 * NumTraits<Scalar>::AddCost, PacketAccess = 0 };
};
} // namespace internal
} // namespace Eigen
// 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
extern "C" RealScalar EIGEN_CAT(REAL_SCALAR_SUFFIX, EIGEN_BLAS_FUNC_NAME(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();
}
extern "C" int EIGEN_CAT(i, EIGEN_BLAS_FUNC_NAME(amax))(int *n, RealScalar *px, int *incx) {
if (*n <= 0) return 0;
Scalar *x = reinterpret_cast<Scalar *>(px);
Eigen::DenseIndex ret;
if (*incx == 1)
make_vector(x, *n).unaryExpr<scalar_norm1_op>().maxCoeff(&ret);
else
make_vector(x, *n, std::abs(*incx)).unaryExpr<scalar_norm1_op>().maxCoeff(&ret);
return int(ret) + 1;
}
extern "C" int EIGEN_CAT(i, EIGEN_BLAS_FUNC_NAME(amin))(int *n, RealScalar *px, int *incx) {
if (*n <= 0) return 0;
Scalar *x = reinterpret_cast<Scalar *>(px);
Eigen::DenseIndex ret;
if (*incx == 1)
make_vector(x, *n).unaryExpr<scalar_norm1_op>().minCoeff(&ret);
else
make_vector(x, *n, std::abs(*incx)).unaryExpr<scalar_norm1_op>().minCoeff(&ret);
return int(ret) + 1;
}
// computes a dot product of a conjugated vector with another vector.
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;
}
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()));
}
// computes a vector-vector dot product without complex conjugation.
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;
}
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();
}
extern "C" RealScalar EIGEN_CAT(REAL_SCALAR_SUFFIX, EIGEN_BLAS_FUNC_NAME(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();
}
EIGEN_BLAS_FUNC(EIGEN_CAT(REAL_SCALAR_SUFFIX, rot))
(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pc, RealScalar *ps) {
if (*n <= 0) return;
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)));
Eigen::Reverse<StridedVectorType> rvx(vx);
Eigen::Reverse<StridedVectorType> rvy(vy);
// TODO implement mixed real-scalar rotations
if (*incx < 0 && *incy > 0)
Eigen::internal::apply_rotation_in_the_plane(rvx, vy, Eigen::JacobiRotation<Scalar>(c, s));
else if (*incx > 0 && *incy < 0)
Eigen::internal::apply_rotation_in_the_plane(vx, rvy, Eigen::JacobiRotation<Scalar>(c, s));
else
Eigen::internal::apply_rotation_in_the_plane(vx, vy, Eigen::JacobiRotation<Scalar>(c, s));
}
EIGEN_BLAS_FUNC(EIGEN_CAT(REAL_SCALAR_SUFFIX, scal))(int *n, RealScalar *palpha, RealScalar *px, int *incx) {
if (*n <= 0) return;
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;
}
third_party/eigen/blas/level1_impl.h
Vendored
+133
View File
@@ -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"
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;
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();
}
EIGEN_BLAS_FUNC(copy)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy) {
if (*n <= 0) return;
Scalar *x = reinterpret_cast<Scalar *>(px);
Scalar *y = reinterpret_cast<Scalar *>(py);
// be careful, *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;
}
}
}
EIGEN_BLAS_FUNC(rotg)(RealScalar *pa, RealScalar *pb, RealScalar *pc, RealScalar *ps) {
using std::abs;
using std::sqrt;
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((Eigen::numext::abs2(a / scale)) + (Eigen::numext::abs2(b / scale)));
alpha = a / abs(a);
*c = abs(a) / norm;
*s = alpha * Eigen::numext::conj(b) / norm;
a = alpha * norm;
}
#endif
// JacobiRotation<Scalar> r;
// r.makeGivens(a,b);
// *c = r.c();
// *s = r.s();
}
EIGEN_BLAS_FUNC(scal)(int *n, RealScalar *palpha, RealScalar *px, int *incx) {
if (*n <= 0) return;
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;
}
EIGEN_BLAS_FUNC(swap)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy) {
if (*n <= 0) return;
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());
}
third_party/eigen/blas/level1_real_impl.h
Vendored
+130
View File
@@ -0,0 +1,130 @@
// 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
extern "C" RealScalar EIGEN_BLAS_FUNC_NAME(asum)(int *n, Scalar *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();
}
extern "C" int EIGEN_CAT(i, EIGEN_BLAS_FUNC_NAME(amax))(int *n, Scalar *px, int *incx) {
if (*n <= 0) return 0;
Scalar *x = reinterpret_cast<Scalar *>(px);
Eigen::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;
}
extern "C" int EIGEN_CAT(i, EIGEN_BLAS_FUNC_NAME(amin))(int *n, Scalar *px, int *incx) {
if (*n <= 0) return 0;
Scalar *x = reinterpret_cast<Scalar *>(px);
Eigen::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;
}
// computes a vector-vector dot product.
extern "C" Scalar EIGEN_BLAS_FUNC_NAME(dot)(int *n, Scalar *px, int *incx, Scalar *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
extern "C" Scalar EIGEN_BLAS_FUNC_NAME(nrm2)(int *n, Scalar *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();
}
EIGEN_BLAS_FUNC(rot)(int *n, Scalar *px, int *incx, Scalar *py, int *incy, Scalar *pc, Scalar *ps) {
// std::cerr << "_rot " << *n << " " << *incx << " " << *incy << "\n";
if (*n <= 0) return;
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)));
Eigen::Reverse<StridedVectorType> rvx(vx);
Eigen::Reverse<StridedVectorType> rvy(vy);
if (*incx < 0 && *incy > 0)
Eigen::internal::apply_rotation_in_the_plane(rvx, vy, Eigen::JacobiRotation<Scalar>(c, s));
else if (*incx > 0 && *incy < 0)
Eigen::internal::apply_rotation_in_the_plane(vx, rvy, Eigen::JacobiRotation<Scalar>(c, s));
else
Eigen::internal::apply_rotation_in_the_plane(vx, vy, Eigen::JacobiRotation<Scalar>(c, s));
}
/*
// performs rotation of points in the modified plane.
EIGEN_BLAS_FUNC(rotm)(int *n, Scalar *px, int *incx, Scalar *py, int *incy, Scalar *param)
{
Scalar* x = reinterpret_cast<Scalar*>(px);
Scalar* y = reinterpret_cast<Scalar*>(py);
// TODO
return 0;
}
// computes the modified parameters for a Givens rotation.
EIGEN_BLAS_FUNC(rotmg)(Scalar *d1, Scalar *d2, Scalar *x1, Scalar *x2, Scalar *param)
{
// TODO
return 0;
}
*/
third_party/eigen/blas/level2_cplx_impl.h
Vendored
+362
View File
@@ -0,0 +1,362 @@
// 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.
*/
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
(Eigen::internal::selfadjoint_matrix_vector_product<Scalar, int, Eigen::ColMajor, Eigen::Upper, false,
false>::run),
// array index: LO
(Eigen::internal::selfadjoint_matrix_vector_product<Scalar, int, Eigen::ColMajor, Eigen::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);
if (*n == 0) return;
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;
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);
}
/** 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.
*/
// 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.
*/
// 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.
*/
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
(Eigen::internal::selfadjoint_packed_rank1_update<Scalar, int, Eigen::ColMajor, Eigen::Upper, false, Conj>::run),
// array index: LO
(Eigen::internal::selfadjoint_packed_rank1_update<Scalar, int, Eigen::ColMajor, Eigen::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);
if (alpha == Scalar(0)) return;
Scalar *x_cpy = get_compact_vector(x, *n, *incx);
int code = UPLO(*uplo);
if (code >= 2 || func[code] == 0) return;
func[code](*n, ap, x_cpy, alpha);
if (x_cpy != x) delete[] x_cpy;
}
/** 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.
*/
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
(Eigen::internal::packed_rank2_update_selector<Scalar, int, Eigen::Upper>::run),
// array index: LO
(Eigen::internal::packed_rank2_update_selector<Scalar, int, Eigen::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);
if (alpha == Scalar(0)) return;
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;
func[code](*n, ap, x_cpy, y_cpy, alpha);
if (x_cpy != x) delete[] x_cpy;
if (y_cpy != y) delete[] y_cpy;
}
/** 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.
*/
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
(Eigen::selfadjoint_rank1_update<Scalar, int, Eigen::ColMajor, Eigen::Upper, false, Conj>::run),
// array index: LO
(Eigen::selfadjoint_rank1_update<Scalar, int, Eigen::ColMajor, Eigen::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);
if (alpha == RealScalar(0)) return;
Scalar *x_cpy = get_compact_vector(x, *n, *incx);
int code = UPLO(*uplo);
if (code >= 2 || func[code] == 0) return;
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;
}
/** 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.
*/
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
(Eigen::internal::rank2_update_selector<Scalar, int, Eigen::Upper>::run),
// array index: LO
(Eigen::internal::rank2_update_selector<Scalar, int, Eigen::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);
if (alpha == Scalar(0)) return;
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;
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;
}
/** 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.
*/
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);
if (alpha == Scalar(0)) return;
Scalar *x_cpy = get_compact_vector(x, *m, *incx);
Scalar *y_cpy = get_compact_vector(y, *n, *incy);
Eigen::internal::general_rank1_update<Scalar, int, Eigen::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;
}
/** 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.
*/
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);
if (alpha == Scalar(0)) return;
Scalar *x_cpy = get_compact_vector(x, *m, *incx);
Scalar *y_cpy = get_compact_vector(y, *n, *incy);
Eigen::internal::general_rank1_update<Scalar, int, Eigen::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;
}
third_party/eigen/blas/level2_impl.h
Vendored
+616
View File
@@ -0,0 +1,616 @@
// 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 Eigen::internal::const_blas_data_mapper<Scalar, Index, StorageOrder> LhsMapper;
typedef Eigen::internal::const_blas_data_mapper<Scalar, Index, Eigen::RowMajor> RhsMapper;
Eigen::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);
}
};
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, Eigen::ColMajor, false, false>::run),
// array index: TR
(general_matrix_vector_product_wrapper<int, Scalar, Eigen::RowMajor, false, false>::run),
// array index: ADJ
(general_matrix_vector_product_wrapper<int, Scalar, Eigen::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);
if (*m == 0 || *n == 0 || (alpha == Scalar(0) && beta == Scalar(1))) return;
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;
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);
}
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 *);
using Eigen::ColMajor;
using Eigen::Lower;
using Eigen::OnTheLeft;
using Eigen::RowMajor;
using Eigen::UnitDiag;
using Eigen::Upper;
static const functype func[16] = {
// array index: NOTR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | 0, false, ColMajor>::run),
// array index: TR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | 0, false, RowMajor>::run),
// array index: ADJ | (UP << 2) | (NUNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | 0, Conj, RowMajor>::run), 0,
// array index: NOTR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | 0, false, ColMajor>::run),
// array index: TR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | 0, false, RowMajor>::run),
// array index: ADJ | (LO << 2) | (NUNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | 0, Conj, RowMajor>::run), 0,
// array index: NOTR | (UP << 2) | (UNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | UnitDiag, false,
ColMajor>::run),
// array index: TR | (UP << 2) | (UNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | UnitDiag, false,
RowMajor>::run),
// array index: ADJ | (UP << 2) | (UNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | UnitDiag, Conj, RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (UNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | UnitDiag, false,
ColMajor>::run),
// array index: TR | (LO << 2) | (UNIT << 3)
(Eigen::internal::triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | UnitDiag, false,
RowMajor>::run),
// array index: ADJ | (LO << 2) | (UNIT << 3)
(Eigen::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);
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);
}
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 &);
using Eigen::ColMajor;
using Eigen::Lower;
using Eigen::OnTheLeft;
using Eigen::RowMajor;
using Eigen::UnitDiag;
using Eigen::Upper;
static const functype func[16] = {
// array index: NOTR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Upper | 0, Scalar, false, Scalar, false, ColMajor>::run),
// array index: TR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Lower | 0, Scalar, false, Scalar, false, RowMajor>::run),
// array index: ADJ | (UP << 2) | (NUNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Lower | 0, Scalar, Conj, Scalar, false, RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Lower | 0, Scalar, false, Scalar, false, ColMajor>::run),
// array index: TR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Upper | 0, Scalar, false, Scalar, false, RowMajor>::run),
// array index: ADJ | (LO << 2) | (NUNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Upper | 0, Scalar, Conj, Scalar, false, RowMajor>::run),
0,
// array index: NOTR | (UP << 2) | (UNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Upper | UnitDiag, Scalar, false, Scalar, false,
ColMajor>::run),
// array index: TR | (UP << 2) | (UNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Lower | UnitDiag, Scalar, false, Scalar, false,
RowMajor>::run),
// array index: ADJ | (UP << 2) | (UNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Lower | UnitDiag, Scalar, Conj, Scalar, false,
RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (UNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Lower | UnitDiag, Scalar, false, Scalar, false,
ColMajor>::run),
// array index: TR | (LO << 2) | (UNIT << 3)
(Eigen::internal::triangular_matrix_vector_product<int, Upper | UnitDiag, Scalar, false, Scalar, false,
RowMajor>::run),
// array index: ADJ | (LO << 2) | (UNIT << 3)
(Eigen::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);
if (*n == 0) return;
Scalar *actual_b = get_compact_vector(b, *n, *incb);
Eigen::Matrix<Scalar, Eigen::Dynamic, 1> res(*n);
res.setZero();
int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3);
if (code >= 16 || func[code] == 0) return;
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;
}
/** 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.
*/
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);
if (*m == 0 || *n == 0 || (alpha == Scalar(0) && beta == Scalar(1))) return;
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);
}
#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.
*/
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;
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);
}
#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.
*/
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 *);
using Eigen::ColMajor;
using Eigen::Lower;
using Eigen::OnTheLeft;
using Eigen::RowMajor;
using Eigen::UnitDiag;
using Eigen::Upper;
static const functype func[16] = {
// array index: NOTR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Upper | 0, Scalar, false, Scalar, ColMajor>::run),
// array index: TR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Lower | 0, Scalar, false, Scalar, RowMajor>::run),
// array index: ADJ | (UP << 2) | (NUNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Lower | 0, Scalar, Conj, Scalar, RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Lower | 0, Scalar, false, Scalar, ColMajor>::run),
// array index: TR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Upper | 0, Scalar, false, Scalar, RowMajor>::run),
// array index: ADJ | (LO << 2) | (NUNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Upper | 0, Scalar, Conj, Scalar, RowMajor>::run),
0,
// array index: NOTR | (UP << 2) | (UNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Upper | UnitDiag, Scalar, false, Scalar, ColMajor>::run),
// array index: TR | (UP << 2) | (UNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Lower | UnitDiag, Scalar, false, Scalar, RowMajor>::run),
// array index: ADJ | (UP << 2) | (UNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Lower | UnitDiag, Scalar, Conj, Scalar, RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (UNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Lower | UnitDiag, Scalar, false, Scalar, ColMajor>::run),
// array index: TR | (LO << 2) | (UNIT << 3)
(Eigen::internal::band_solve_triangular_selector<int, Upper | UnitDiag, Scalar, false, Scalar, RowMajor>::run),
// array index: ADJ | (LO << 2) | (UNIT << 3)
(Eigen::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);
if (*n == 0 || (*k == 0 && DIAG(*diag) == UNIT)) return;
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;
func[code](*n, *k, a, *lda, actual_x);
if (actual_x != x) delete[] copy_back(actual_x, x, actual_n, *incx);
}
/** 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.
*/
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);
using Eigen::ColMajor;
using Eigen::Lower;
using Eigen::OnTheLeft;
using Eigen::RowMajor;
using Eigen::UnitDiag;
using Eigen::Upper;
static const functype func[16] = {
// array index: NOTR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Upper | 0, Scalar, false, Scalar, false,
ColMajor>::run),
// array index: TR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Lower | 0, Scalar, false, Scalar, false,
RowMajor>::run),
// array index: ADJ | (UP << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Lower | 0, Scalar, Conj, Scalar, false,
RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Lower | 0, Scalar, false, Scalar, false,
ColMajor>::run),
// array index: TR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Upper | 0, Scalar, false, Scalar, false,
RowMajor>::run),
// array index: ADJ | (LO << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Upper | 0, Scalar, Conj, Scalar, false,
RowMajor>::run),
0,
// array index: NOTR | (UP << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Upper | UnitDiag, Scalar, false, Scalar, false,
ColMajor>::run),
// array index: TR | (UP << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Lower | UnitDiag, Scalar, false, Scalar, false,
RowMajor>::run),
// array index: ADJ | (UP << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Lower | UnitDiag, Scalar, Conj, Scalar, false,
RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Lower | UnitDiag, Scalar, false, Scalar, false,
ColMajor>::run),
// array index: TR | (LO << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_matrix_vector_product<int, Upper | UnitDiag, Scalar, false, Scalar, false,
RowMajor>::run),
// array index: ADJ | (LO << 2) | (UNIT << 3)
(Eigen::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);
if (*n == 0) return;
Scalar *actual_x = get_compact_vector(x, *n, *incx);
Eigen::Matrix<Scalar, Eigen::Dynamic, 1> res(*n);
res.setZero();
int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3);
if (code >= 16 || func[code] == 0) return;
func[code](*n, ap, actual_x, res.data(), Scalar(1));
copy_back(res.data(), x, *n, *incx);
if (actual_x != x) delete[] actual_x;
}
/** 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.
*/
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 *);
using Eigen::ColMajor;
using Eigen::Lower;
using Eigen::OnTheLeft;
using Eigen::RowMajor;
using Eigen::UnitDiag;
using Eigen::Upper;
static const functype func[16] = {
// array index: NOTR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | 0, false,
ColMajor>::run),
// array index: TR | (UP << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | 0, false,
RowMajor>::run),
// array index: ADJ | (UP << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | 0, Conj, RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | 0, false,
ColMajor>::run),
// array index: TR | (LO << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | 0, false,
RowMajor>::run),
// array index: ADJ | (LO << 2) | (NUNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | 0, Conj, RowMajor>::run),
0,
// array index: NOTR | (UP << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | UnitDiag, false,
ColMajor>::run),
// array index: TR | (UP << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | UnitDiag, false,
RowMajor>::run),
// array index: ADJ | (UP << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | UnitDiag, Conj,
RowMajor>::run),
0,
// array index: NOTR | (LO << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Lower | UnitDiag, false,
ColMajor>::run),
// array index: TR | (LO << 2) | (UNIT << 3)
(Eigen::internal::packed_triangular_solve_vector<Scalar, Scalar, int, OnTheLeft, Upper | UnitDiag, false,
RowMajor>::run),
// array index: ADJ | (LO << 2) | (UNIT << 3)
(Eigen::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);
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);
}
third_party/eigen/blas/level2_real_impl.h
Vendored
+313
View File
@@ -0,0 +1,313 @@
// 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
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);
using Eigen::ColMajor;
using Eigen::Lower;
using Eigen::Upper;
static const functype func[2] = {
// array index: UP
(Eigen::internal::selfadjoint_matrix_vector_product<Scalar, int, ColMajor, Upper, false, false>::run),
// array index: LO
(Eigen::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);
if (*n == 0) return;
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;
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);
}
// C := alpha*x*x' + C
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 &);
using Eigen::ColMajor;
using Eigen::Lower;
using Eigen::Upper;
static const functype func[2] = {
// array index: UP
(Eigen::selfadjoint_rank1_update<Scalar, int, ColMajor, Upper, false, Conj>::run),
// array index: LO
(Eigen::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);
if (*n == 0 || alpha == Scalar(0)) return;
// 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;
func[code](*n, c, *ldc, x_cpy, x_cpy, alpha);
if (x_cpy != x) delete[] x_cpy;
}
// C := alpha*x*y' + alpha*y*x' + C
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
(Eigen::internal::rank2_update_selector<Scalar, int, Eigen::Upper>::run),
// array index: LO
(Eigen::internal::rank2_update_selector<Scalar, int, Eigen::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);
if (alpha == Scalar(0)) return;
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;
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);
}
/** 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.
*/
// 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.
*
*/
// 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.
*/
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
(Eigen::internal::selfadjoint_packed_rank1_update<Scalar, int, Eigen::ColMajor, Eigen::Upper, false, false>::run),
// array index: LO
(Eigen::internal::selfadjoint_packed_rank1_update<Scalar, int, Eigen::ColMajor, Eigen::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);
if (alpha == Scalar(0)) return;
Scalar *x_cpy = get_compact_vector(x, *n, *incx);
int code = UPLO(*uplo);
if (code >= 2 || func[code] == 0) return;
func[code](*n, ap, x_cpy, alpha);
if (x_cpy != x) delete[] x_cpy;
}
/** 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.
*/
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
(Eigen::internal::packed_rank2_update_selector<Scalar, int, Eigen::Upper>::run),
// array index: LO
(Eigen::internal::packed_rank2_update_selector<Scalar, int, Eigen::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);
if (alpha == Scalar(0)) return;
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;
func[code](*n, ap, x_cpy, y_cpy, alpha);
if (x_cpy != x) delete[] x_cpy;
if (y_cpy != y) delete[] y_cpy;
}
/** 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.
*/
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);
if (alpha == Scalar(0)) return;
Scalar *x_cpy = get_compact_vector(x, *m, *incx);
Scalar *y_cpy = get_compact_vector(y, *n, *incy);
Eigen::internal::general_rank1_update<Scalar, int, Eigen::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;
}
third_party/eigen/blas/level3_impl.h
Vendored
+985
View File
@@ -0,0 +1,985 @@
// 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"
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) {
using Eigen::ColMajor;
using Eigen::DenseIndex;
using Eigen::Dynamic;
using Eigen::RowMajor;
typedef void (*functype)(DenseIndex, DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex,
Scalar *, DenseIndex, DenseIndex, Scalar, Eigen::internal::level3_blocking<Scalar, Scalar> &,
Eigen::internal::GemmParallelInfo<DenseIndex> *);
static const functype func[12] = {
// array index: NOTR | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_product<DenseIndex, Scalar, ColMajor, false, Scalar, ColMajor, false,
ColMajor, 1>::run),
// array index: TR | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_product<DenseIndex, Scalar, RowMajor, false, Scalar, ColMajor, false,
ColMajor, 1>::run),
// array index: ADJ | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, ColMajor, false,
ColMajor, 1>::run),
0,
// array index: NOTR | (TR << 2)
(Eigen::internal::general_matrix_matrix_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor, false,
ColMajor, 1>::run),
// array index: TR | (TR << 2)
(Eigen::internal::general_matrix_matrix_product<DenseIndex, Scalar, RowMajor, false, Scalar, RowMajor, false,
ColMajor, 1>::run),
// array index: ADJ | (TR << 2)
(Eigen::internal::general_matrix_matrix_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, RowMajor, false,
ColMajor, 1>::run),
0,
// array index: NOTR | (ADJ << 2)
(Eigen::internal::general_matrix_matrix_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor, Conj,
ColMajor, 1>::run),
// array index: TR | (ADJ << 2)
(Eigen::internal::general_matrix_matrix_product<DenseIndex, Scalar, RowMajor, false, Scalar, RowMajor, Conj,
ColMajor, 1>::run),
// array index: ADJ | (ADJ << 2)
(Eigen::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);
if (*m == 0 || *n == 0) return;
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;
Eigen::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);
}
EIGEN_BLAS_FUNC(gemmtr)
(const char *uplo, const char *opa, const char *opb, 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) {
using Eigen::ColMajor;
using Eigen::DenseIndex;
using Eigen::Dynamic;
using Eigen::Lower;
using Eigen::RowMajor;
using Eigen::Upper;
typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *,
DenseIndex, DenseIndex, const Scalar &, Eigen::internal::level3_blocking<Scalar, Scalar> &);
static const functype func[24] = {
// Upper-triangular result.
// array index: NOTR | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, ColMajor,
false, ColMajor, 1, Upper>::run),
// array index: TR | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, false, Scalar, ColMajor,
false, ColMajor, 1, Upper>::run),
// array index: ADJ | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, ColMajor,
false, ColMajor, 1, Upper>::run),
0,
// array index: NOTR | (TR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor,
false, ColMajor, 1, Upper>::run),
// array index: TR | (TR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, false, Scalar, RowMajor,
false, ColMajor, 1, Upper>::run),
// array index: ADJ | (TR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, RowMajor,
false, ColMajor, 1, Upper>::run),
0,
// array index: NOTR | (ADJ << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor,
Conj, ColMajor, 1, Upper>::run),
// array index: TR | (ADJ << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, false, Scalar, RowMajor,
Conj, ColMajor, 1, Upper>::run),
// array index: ADJ | (ADJ << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, RowMajor,
Conj, ColMajor, 1, Upper>::run),
0,
// Lower-triangular result.
// array index: NOTR | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, ColMajor,
false, ColMajor, 1, Lower>::run),
// array index: TR | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, false, Scalar, ColMajor,
false, ColMajor, 1, Lower>::run),
// array index: ADJ | (NOTR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, ColMajor,
false, ColMajor, 1, Lower>::run),
0,
// array index: NOTR | (TR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor,
false, ColMajor, 1, Lower>::run),
// array index: TR | (TR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, false, Scalar, RowMajor,
false, ColMajor, 1, Lower>::run),
// array index: ADJ | (TR << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, RowMajor,
false, ColMajor, 1, Lower>::run),
0,
// array index: NOTR | (ADJ << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor,
Conj, ColMajor, 1, Lower>::run),
// array index: TR | (ADJ << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, false, Scalar, RowMajor,
Conj, ColMajor, 1, Lower>::run),
// array index: ADJ | (ADJ << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, RowMajor,
Conj, ColMajor, 1, Lower>::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 (UPLO(*uplo) == INVALID)
info = 1;
else if (OP(*opa) == INVALID)
info = 2;
else if (OP(*opb) == INVALID)
info = 3;
else if (*n < 0)
info = 4;
else if (*k < 0)
info = 5;
else if (*lda < std::max(1, (OP(*opa) == NOTR) ? *n : *k))
info = 8;
else if (*ldb < std::max(1, (OP(*opb) == NOTR) ? *k : *n))
info = 10;
else if (*ldc < std::max(1, *n))
info = 13;
if (info) return xerbla_(SCALAR_SUFFIX_UP "GEMMTR ", &info);
if (*n == 0) return;
const int upper = (UPLO(*uplo) == UP);
if (beta != Scalar(1)) {
if (beta == Scalar(0)) {
if (upper) {
matrix(c, *n, *n, *ldc).triangularView<Eigen::Upper>().setZero();
} else {
matrix(c, *n, *n, *ldc).triangularView<Eigen::Lower>().setZero();
}
} else {
if (upper) {
matrix(c, *n, *n, *ldc).triangularView<Eigen::Upper>() *= beta;
} else {
matrix(c, *n, *n, *ldc).triangularView<Eigen::Lower>() *= beta;
}
}
}
if (*k == 0) return;
Eigen::internal::gemm_blocking_space<ColMajor, Scalar, Scalar, Dynamic, Dynamic, Dynamic> blocking(*n, *n, *k, 1,
false);
int code = OP(*opa) | ((OP(*opb) << 2) + (UPLO(*uplo) * 12));
func[code](*n, *k, a, *lda, b, *ldb, c, 1, *ldc, alpha, blocking);
}
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) {
using Eigen::ColMajor;
using Eigen::DenseIndex;
using Eigen::Dynamic;
using Eigen::Lower;
using Eigen::OnTheLeft;
using Eigen::OnTheRight;
using Eigen::RowMajor;
using Eigen::UnitDiag;
using Eigen::Upper;
typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, DenseIndex,
Eigen::internal::level3_blocking<Scalar, Scalar> &);
static const functype func[32] = {
// array index: NOTR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Upper | 0, false, ColMajor, ColMajor,
1>::run),
// array index: TR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Lower | 0, false, RowMajor, ColMajor,
1>::run),
// array index: ADJ | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Lower | 0, Conj, RowMajor, ColMajor,
1>::run),
0,
// array index: NOTR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Upper | 0, false, ColMajor, ColMajor,
1>::run),
// array index: TR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Lower | 0, false, RowMajor, ColMajor,
1>::run),
// array index: ADJ | (RIGHT << 2) | (UP << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Lower | 0, Conj, RowMajor, ColMajor,
1>::run),
0,
// array index: NOTR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Lower | 0, false, ColMajor, ColMajor,
1>::run),
// array index: TR | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Upper | 0, false, RowMajor, ColMajor,
1>::run),
// array index: ADJ | (LEFT << 2) | (LO << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Upper | 0, Conj, RowMajor, ColMajor,
1>::run),
0,
// array index: NOTR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Lower | 0, false, ColMajor, ColMajor,
1>::run),
// array index: TR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Upper | 0, false, RowMajor, ColMajor,
1>::run),
// array index: ADJ | (RIGHT << 2) | (LO << 3) | (NUNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Upper | 0, Conj, RowMajor, ColMajor,
1>::run),
0,
// array index: NOTR | (LEFT << 2) | (UP << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Upper | UnitDiag, false, ColMajor,
ColMajor, 1>::run),
// array index: TR | (LEFT << 2) | (UP << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Lower | UnitDiag, false, RowMajor,
ColMajor, 1>::run),
// array index: ADJ | (LEFT << 2) | (UP << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Lower | UnitDiag, Conj, RowMajor,
ColMajor, 1>::run),
0,
// array index: NOTR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Upper | UnitDiag, false, ColMajor,
ColMajor, 1>::run),
// array index: TR | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Lower | UnitDiag, false, RowMajor,
ColMajor, 1>::run),
// array index: ADJ | (RIGHT << 2) | (UP << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Lower | UnitDiag, Conj, RowMajor,
ColMajor, 1>::run),
0,
// array index: NOTR | (LEFT << 2) | (LO << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Lower | UnitDiag, false, ColMajor,
ColMajor, 1>::run),
// array index: TR | (LEFT << 2) | (LO << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Upper | UnitDiag, false, RowMajor,
ColMajor, 1>::run),
// array index: ADJ | (LEFT << 2) | (LO << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheLeft, Upper | UnitDiag, Conj, RowMajor,
ColMajor, 1>::run),
0,
// array index: NOTR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Lower | UnitDiag, false, ColMajor,
ColMajor, 1>::run),
// array index: TR | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
(Eigen::internal::triangular_solve_matrix<Scalar, DenseIndex, OnTheRight, Upper | UnitDiag, false, RowMajor,
ColMajor, 1>::run),
// array index: ADJ | (RIGHT << 2) | (LO << 3) | (UNIT << 4)
(Eigen::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);
if (*m == 0 || *n == 0) return;
int code = OP(*opa) | (SIDE(*side) << 2) | (UPLO(*uplo) << 3) | (DIAG(*diag) << 4);
if (SIDE(*side) == LEFT) {
Eigen::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 {
Eigen::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;
}
// b = alpha*op(a)*b for side = 'L'or'l'
// b = alpha*b*op(a) for side = 'R'or'r'
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) {
using Eigen::ColMajor;
using Eigen::DenseIndex;
using Eigen::Dynamic;
using Eigen::Lower;
using Eigen::RowMajor;
using Eigen::UnitDiag;
using Eigen::Upper;
typedef void (*functype)(DenseIndex, DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex,
Scalar *, DenseIndex, DenseIndex, const Scalar &,
Eigen::internal::level3_blocking<Scalar, Scalar> &);
static const functype func[32] = {
// array index: NOTR | (LEFT << 2) | (UP << 3) | (NUNIT << 4)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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)
(Eigen::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);
int code = OP(*opa) | (SIDE(*side) << 2) | (UPLO(*uplo) << 3) | (DIAG(*diag) << 4);
if (*m == 0 || *n == 0) return;
// FIXME find a way to avoid this copy
Eigen::Matrix<Scalar, Dynamic, Dynamic, ColMajor> tmp = matrix(b, *m, *n, *ldb);
matrix(b, *m, *n, *ldb).setZero();
if (SIDE(*side) == LEFT) {
Eigen::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 {
Eigen::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);
}
}
// c = alpha*a*b + beta*c for side = 'L'or'l'
// c = alpha*b*a + beta*c for side = 'R'or'r
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) {
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);
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;
int size = (SIDE(*side) == LEFT) ? (*m) : (*n);
using Eigen::ColMajor;
using Eigen::DenseIndex;
using Eigen::Dynamic;
using Eigen::Lower;
using Eigen::RowMajor;
using Eigen::Upper;
#if ISCOMPLEX
// FIXME add support for symmetric complex matrix
Eigen::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
Eigen::internal::gemm_blocking_space<ColMajor, Scalar, Scalar, Dynamic, Dynamic, Dynamic> blocking(*m, *n, size, 1,
false);
if (SIDE(*side) == LEFT)
if (UPLO(*uplo) == UP)
Eigen::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)
Eigen::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;
else if (SIDE(*side) == RIGHT)
if (UPLO(*uplo) == UP)
Eigen::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)
Eigen::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;
else
return;
#endif
}
// 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'
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) {
using Eigen::ColMajor;
using Eigen::DenseIndex;
using Eigen::Dynamic;
using Eigen::Lower;
using Eigen::RowMajor;
using Eigen::Upper;
#if !ISCOMPLEX
typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *,
DenseIndex, DenseIndex, const Scalar &, Eigen::internal::level3_blocking<Scalar, Scalar> &);
static const functype func[8] = {
// array index: NOTR | (UP << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor,
Conj, ColMajor, 1, Upper>::run),
// array index: TR | (UP << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, false, Scalar, ColMajor,
Conj, ColMajor, 1, Upper>::run),
// array index: ADJ | (UP << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, ColMajor,
false, ColMajor, 1, Upper>::run),
0,
// array index: NOTR | (LO << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor,
Conj, ColMajor, 1, Lower>::run),
// array index: TR | (LO << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, false, Scalar, ColMajor,
Conj, ColMajor, 1, Lower>::run),
// array index: ADJ | (LO << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, ColMajor,
false, ColMajor, 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);
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;
#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
Eigen::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
}
// 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'
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);
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);
using Eigen::Lower;
using Eigen::Upper;
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;
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);
}
}
#if ISCOMPLEX
// c = alpha*a*b + beta*c for side = 'L'or'l'
// c = alpha*b*a + beta*c for side = 'R'or'r
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);
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);
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;
using Eigen::ColMajor;
using Eigen::DenseIndex;
using Eigen::Dynamic;
using Eigen::RowMajor;
using Eigen::Upper;
int size = (SIDE(*side) == LEFT) ? (*m) : (*n);
Eigen::internal::gemm_blocking_space<ColMajor, Scalar, Scalar, Dynamic, Dynamic, Dynamic> blocking(*m, *n, size, 1,
false);
if (SIDE(*side) == LEFT) {
if (UPLO(*uplo) == UP)
Eigen::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)
Eigen::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;
} 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)
Eigen::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;
} else {
return;
}
}
// c = alpha*a*conj(a') + beta*c for op = 'N'or'n'
// c = alpha*conj(a')*a + beta*c for op = 'C'or'c'
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) {
using Eigen::ColMajor;
using Eigen::DenseIndex;
using Eigen::Dynamic;
using Eigen::Lower;
using Eigen::RowMajor;
using Eigen::StrictlyLower;
using Eigen::StrictlyUpper;
using Eigen::Upper;
typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *,
DenseIndex, DenseIndex, const Scalar &, Eigen::internal::level3_blocking<Scalar, Scalar> &);
static const functype func[8] = {
// array index: NOTR | (UP << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor,
Conj, ColMajor, 1, Upper>::run),
0,
// array index: ADJ | (UP << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, RowMajor, Conj, Scalar, ColMajor,
false, ColMajor, 1, Upper>::run),
0,
// array index: NOTR | (LO << 2)
(Eigen::internal::general_matrix_matrix_triangular_product<DenseIndex, Scalar, ColMajor, false, Scalar, RowMajor,
Conj, ColMajor, 1, Lower>::run),
0,
// array index: ADJ | (LO << 2)
(Eigen::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;
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);
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)) {
Eigen::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();
}
}
// 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'
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;
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);
using Eigen::Lower;
using Eigen::StrictlyLower;
using Eigen::StrictlyUpper;
using Eigen::Upper;
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;
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() +
Eigen::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() +
Eigen::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) +
Eigen::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) +
Eigen::numext::conj(alpha) * matrix(b, *k, *n, *ldb).adjoint() * matrix(a, *k, *n, *lda);
}
}
#endif
third_party/eigen/blas/single.cpp
Vendored
+23
View File
@@ -0,0 +1,23 @@
// 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 EIGEN_BLAS_FUNC_NAME(dsdot)(int* n, float* alpha, float* x, int* incx, float* y, int* incy) {
return double(*alpha) + BLASFUNC(dsdot)(n, x, incx, y, incy);
}
third_party/eigen/blas/testing/CMakeLists.txt
Vendored
+52
View File
@@ -0,0 +1,52 @@
include(CheckLanguage)
check_language(Fortran)
if(CMAKE_Fortran_COMPILER)
enable_language(Fortran)
set(EIGEN_Fortran_COMPILER_WORKS ON)
else()
set(EIGEN_Fortran_COMPILER_WORKS OFF)
endif()
if (EIGEN_Fortran_COMPILER_WORKS)
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(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)
endif()
third_party/eigen/blas/testing/cblat1.f
Vendored
+724
View File
@@ -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 ACCOMMODATE 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
third_party/eigen/blas/testing/cblat2.dat
Vendored
+35
View File
@@ -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.
third_party/eigen/blas/testing/cblat2.f
Vendored
+3279
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/cblat3.dat
Vendored
+23
View File
@@ -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.
third_party/eigen/blas/testing/cblat3.f
Vendored
+3492
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/dblat1.f
Vendored
+1065
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/dblat2.dat
Vendored
+34
View File
@@ -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.
third_party/eigen/blas/testing/dblat2.f
Vendored
+3176
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/dblat3.dat
Vendored
+20
View File
@@ -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.
third_party/eigen/blas/testing/dblat3.f
Vendored
+2873
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/runblastest.sh
Vendored
+45
View File
@@ -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
third_party/eigen/blas/testing/sblat1.f
Vendored
+1021
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/sblat2.dat
Vendored
+34
View File
@@ -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.
third_party/eigen/blas/testing/sblat2.f
Vendored
+3176
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/sblat3.dat
Vendored
+20
View File
@@ -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.
third_party/eigen/blas/testing/sblat3.f
Vendored
+2873
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/zblat1.f
Vendored
+724
View File
@@ -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 ACCOMMODATE 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
third_party/eigen/blas/testing/zblat2.dat
Vendored
+35
View File
@@ -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.
third_party/eigen/blas/testing/zblat2.f
Vendored
+3287
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/testing/zblat3.dat
Vendored
+23
View File
@@ -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.
third_party/eigen/blas/testing/zblat3.f
Vendored
+3502
View File
File diff suppressed because it is too large Load Diff
third_party/eigen/blas/xerbla.cpp
Vendored
+18
View File
@@ -0,0 +1,18 @@
#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 void xerbla_(const char *msg, int *info) { printf("Eigen BLAS ERROR #%i: %s\n", *info, msg); }
#ifdef __cplusplus
}
#endif