diff options
Diffstat (limited to 'eigen/blas')
65 files changed, 0 insertions, 39248 deletions
diff --git a/eigen/blas/BandTriangularSolver.h b/eigen/blas/BandTriangularSolver.h deleted file mode 100644 index ce2d74d..0000000 --- a/eigen/blas/BandTriangularSolver.h +++ /dev/null @@ -1,97 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2011 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#ifndef EIGEN_BAND_TRIANGULARSOLVER_H -#define EIGEN_BAND_TRIANGULARSOLVER_H - -namespace internal { - - /* \internal - * Solve Ax=b with A a band triangular matrix - * TODO: extend it to matrices for x abd b */ -template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar, int StorageOrder> -struct band_solve_triangular_selector; - - -template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar> -struct band_solve_triangular_selector<Index,Mode,LhsScalar,ConjLhs,RhsScalar,RowMajor> -{ - typedef Map<const Matrix<LhsScalar,Dynamic,Dynamic,RowMajor>, 0, OuterStride<> > LhsMap; - typedef Map<Matrix<RhsScalar,Dynamic,1> > RhsMap; - enum { IsLower = (Mode&Lower) ? 1 : 0 }; - static void run(Index size, Index k, const LhsScalar* _lhs, Index lhsStride, RhsScalar* _other) - { - const LhsMap lhs(_lhs,size,k+1,OuterStride<>(lhsStride)); - RhsMap other(_other,size,1); - typename internal::conditional< - ConjLhs, - const CwiseUnaryOp<typename internal::scalar_conjugate_op<LhsScalar>,LhsMap>, - const LhsMap&> - ::type cjLhs(lhs); - - for(int col=0 ; col<other.cols() ; ++col) - { - for(int ii=0; ii<size; ++ii) - { - int i = IsLower ? ii : size-ii-1; - int actual_k = (std::min)(k,ii); - int actual_start = IsLower ? k-actual_k : 1; - - if(actual_k>0) - other.coeffRef(i,col) -= cjLhs.row(i).segment(actual_start,actual_k).transpose() - .cwiseProduct(other.col(col).segment(IsLower ? i-actual_k : i+1,actual_k)).sum(); - - if((Mode&UnitDiag)==0) - other.coeffRef(i,col) /= cjLhs(i,IsLower ? k : 0); - } - } - } - -}; - -template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar> -struct band_solve_triangular_selector<Index,Mode,LhsScalar,ConjLhs,RhsScalar,ColMajor> -{ - typedef Map<const Matrix<LhsScalar,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> > LhsMap; - typedef Map<Matrix<RhsScalar,Dynamic,1> > RhsMap; - enum { IsLower = (Mode&Lower) ? 1 : 0 }; - static void run(Index size, Index k, const LhsScalar* _lhs, Index lhsStride, RhsScalar* _other) - { - const LhsMap lhs(_lhs,k+1,size,OuterStride<>(lhsStride)); - RhsMap other(_other,size,1); - typename internal::conditional< - ConjLhs, - const CwiseUnaryOp<typename internal::scalar_conjugate_op<LhsScalar>,LhsMap>, - const LhsMap&> - ::type cjLhs(lhs); - - for(int col=0 ; col<other.cols() ; ++col) - { - for(int ii=0; ii<size; ++ii) - { - int i = IsLower ? ii : size-ii-1; - int actual_k = (std::min)(k,size-ii-1); - int actual_start = IsLower ? 1 : k-actual_k; - - if((Mode&UnitDiag)==0) - other.coeffRef(i,col) /= cjLhs(IsLower ? 0 : k, i); - - if(actual_k>0) - other.col(col).segment(IsLower ? i+1 : i-actual_k, actual_k) - -= other.coeff(i,col) * cjLhs.col(i).segment(actual_start,actual_k); - - } - } - } -}; - - -} // end namespace internal - -#endif // EIGEN_BAND_TRIANGULARSOLVER_H diff --git a/eigen/blas/CMakeLists.txt b/eigen/blas/CMakeLists.txt deleted file mode 100644 index 9887d58..0000000 --- a/eigen/blas/CMakeLists.txt +++ /dev/null @@ -1,57 +0,0 @@ - -project(EigenBlas CXX) - -include("../cmake/language_support.cmake") - -workaround_9220(Fortran EIGEN_Fortran_COMPILER_WORKS) - -if(EIGEN_Fortran_COMPILER_WORKS) - enable_language(Fortran OPTIONAL) - if(NOT CMAKE_Fortran_COMPILER) - set(EIGEN_Fortran_COMPILER_WORKS OFF) - endif() -endif() - -add_custom_target(blas) - -set(EigenBlas_SRCS single.cpp double.cpp complex_single.cpp complex_double.cpp xerbla.cpp - f2c/srotm.c f2c/srotmg.c f2c/drotm.c f2c/drotmg.c - f2c/lsame.c f2c/dspmv.c f2c/ssbmv.c f2c/chbmv.c - f2c/sspmv.c f2c/zhbmv.c f2c/chpmv.c f2c/dsbmv.c - f2c/zhpmv.c f2c/dtbmv.c f2c/stbmv.c f2c/ctbmv.c - f2c/ztbmv.c f2c/d_cnjg.c f2c/r_cnjg.c - ) - -if (EIGEN_Fortran_COMPILER_WORKS) - set(EigenBlas_SRCS ${EigenBlas_SRCS} fortran/complexdots.f) -else() - set(EigenBlas_SRCS ${EigenBlas_SRCS} f2c/complexdots.c) -endif() - -add_library(eigen_blas_static ${EigenBlas_SRCS}) -add_library(eigen_blas SHARED ${EigenBlas_SRCS}) - -if(EIGEN_STANDARD_LIBRARIES_TO_LINK_TO) - target_link_libraries(eigen_blas_static ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO}) - target_link_libraries(eigen_blas ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO}) -endif() - -add_dependencies(blas eigen_blas eigen_blas_static) - -install(TARGETS eigen_blas eigen_blas_static - RUNTIME DESTINATION bin - LIBRARY DESTINATION lib - ARCHIVE DESTINATION lib) - -if(EIGEN_Fortran_COMPILER_WORKS) - -if(BUILD_TESTING) - if(EIGEN_LEAVE_TEST_IN_ALL_TARGET) - add_subdirectory(testing) # can't do EXCLUDE_FROM_ALL here, breaks CTest - else() - add_subdirectory(testing EXCLUDE_FROM_ALL) - endif() -endif() - -endif() - diff --git a/eigen/blas/GeneralRank1Update.h b/eigen/blas/GeneralRank1Update.h deleted file mode 100644 index 07d388c..0000000 --- a/eigen/blas/GeneralRank1Update.h +++ /dev/null @@ -1,44 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#ifndef EIGEN_GENERAL_RANK1UPDATE_H -#define EIGEN_GENERAL_RANK1UPDATE_H - -namespace internal { - -/* Optimized matrix += alpha * uv' */ -template<typename Scalar, typename Index, int StorageOrder, bool ConjLhs, bool ConjRhs> -struct general_rank1_update; - -template<typename Scalar, typename Index, bool ConjLhs, bool ConjRhs> -struct general_rank1_update<Scalar,Index,ColMajor,ConjLhs,ConjRhs> -{ - static void run(Index rows, Index cols, Scalar* mat, Index stride, const Scalar* u, const Scalar* v, Scalar alpha) - { - typedef Map<const Matrix<Scalar,Dynamic,1> > OtherMap; - typedef typename conj_expr_if<ConjLhs,OtherMap>::type ConjRhsType; - conj_if<ConjRhs> cj; - - for (Index i=0; i<cols; ++i) - Map<Matrix<Scalar,Dynamic,1> >(mat+stride*i,rows) += alpha * cj(v[i]) * ConjRhsType(OtherMap(u,rows)); - } -}; - -template<typename Scalar, typename Index, bool ConjLhs, bool ConjRhs> -struct general_rank1_update<Scalar,Index,RowMajor,ConjLhs,ConjRhs> -{ - static void run(Index rows, Index cols, Scalar* mat, Index stride, const Scalar* u, const Scalar* v, Scalar alpha) - { - general_rank1_update<Scalar,Index,ColMajor,ConjRhs,ConjRhs>::run(rows,cols,mat,stride,u,v,alpha); - } -}; - -} // end namespace internal - -#endif // EIGEN_GENERAL_RANK1UPDATE_H diff --git a/eigen/blas/PackedSelfadjointProduct.h b/eigen/blas/PackedSelfadjointProduct.h deleted file mode 100644 index 07327a2..0000000 --- a/eigen/blas/PackedSelfadjointProduct.h +++ /dev/null @@ -1,53 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#ifndef EIGEN_SELFADJOINT_PACKED_PRODUCT_H -#define EIGEN_SELFADJOINT_PACKED_PRODUCT_H - -namespace internal { - -/* Optimized matrix += alpha * uv' - * The matrix is in packed form. - */ -template<typename Scalar, typename Index, int StorageOrder, int UpLo, bool ConjLhs, bool ConjRhs> -struct selfadjoint_packed_rank1_update; - -template<typename Scalar, typename Index, int UpLo, bool ConjLhs, bool ConjRhs> -struct selfadjoint_packed_rank1_update<Scalar,Index,ColMajor,UpLo,ConjLhs,ConjRhs> -{ - typedef typename NumTraits<Scalar>::Real RealScalar; - static void run(Index size, Scalar* mat, const Scalar* vec, RealScalar alpha) - { - typedef Map<const Matrix<Scalar,Dynamic,1> > OtherMap; - typedef typename conj_expr_if<ConjLhs,OtherMap>::type ConjRhsType; - conj_if<ConjRhs> cj; - - for (Index i=0; i<size; ++i) - { - Map<Matrix<Scalar,Dynamic,1> >(mat, UpLo==Lower ? size-i : (i+1)) += alpha * cj(vec[i]) * ConjRhsType(OtherMap(vec+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1))); - //FIXME This should be handled outside. - mat[UpLo==Lower ? 0 : i] = numext::real(mat[UpLo==Lower ? 0 : i]); - mat += UpLo==Lower ? size-i : (i+1); - } - } -}; - -template<typename Scalar, typename Index, int UpLo, bool ConjLhs, bool ConjRhs> -struct selfadjoint_packed_rank1_update<Scalar,Index,RowMajor,UpLo,ConjLhs,ConjRhs> -{ - typedef typename NumTraits<Scalar>::Real RealScalar; - static void run(Index size, Scalar* mat, const Scalar* vec, RealScalar alpha) - { - selfadjoint_packed_rank1_update<Scalar,Index,ColMajor,UpLo==Lower?Upper:Lower,ConjRhs,ConjLhs>::run(size,mat,vec,alpha); - } -}; - -} // end namespace internal - -#endif // EIGEN_SELFADJOINT_PACKED_PRODUCT_H diff --git a/eigen/blas/PackedTriangularMatrixVector.h b/eigen/blas/PackedTriangularMatrixVector.h deleted file mode 100644 index 0039536..0000000 --- a/eigen/blas/PackedTriangularMatrixVector.h +++ /dev/null @@ -1,79 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#ifndef EIGEN_PACKED_TRIANGULAR_MATRIX_VECTOR_H -#define EIGEN_PACKED_TRIANGULAR_MATRIX_VECTOR_H - -namespace internal { - -template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar, bool ConjRhs, int StorageOrder> -struct packed_triangular_matrix_vector_product; - -template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar, bool ConjRhs> -struct packed_triangular_matrix_vector_product<Index,Mode,LhsScalar,ConjLhs,RhsScalar,ConjRhs,ColMajor> -{ - typedef typename ScalarBinaryOpTraits<LhsScalar, RhsScalar>::ReturnType ResScalar; - enum { - IsLower = (Mode & Lower) ==Lower, - HasUnitDiag = (Mode & UnitDiag)==UnitDiag, - HasZeroDiag = (Mode & ZeroDiag)==ZeroDiag - }; - static void run(Index size, const LhsScalar* lhs, const RhsScalar* rhs, ResScalar* res, ResScalar alpha) - { - internal::conj_if<ConjRhs> cj; - typedef Map<const Matrix<LhsScalar,Dynamic,1> > LhsMap; - typedef typename conj_expr_if<ConjLhs,LhsMap>::type ConjLhsType; - typedef Map<Matrix<ResScalar,Dynamic,1> > ResMap; - - for (Index i=0; i<size; ++i) - { - Index s = IsLower&&(HasUnitDiag||HasZeroDiag) ? 1 : 0; - Index r = IsLower ? size-i: i+1; - if (EIGEN_IMPLIES(HasUnitDiag||HasZeroDiag, (--r)>0)) - ResMap(res+(IsLower ? s+i : 0),r) += alpha * cj(rhs[i]) * ConjLhsType(LhsMap(lhs+s,r)); - if (HasUnitDiag) - res[i] += alpha * cj(rhs[i]); - lhs += IsLower ? size-i: i+1; - } - }; -}; - -template<typename Index, int Mode, typename LhsScalar, bool ConjLhs, typename RhsScalar, bool ConjRhs> -struct packed_triangular_matrix_vector_product<Index,Mode,LhsScalar,ConjLhs,RhsScalar,ConjRhs,RowMajor> -{ - typedef typename ScalarBinaryOpTraits<LhsScalar, RhsScalar>::ReturnType ResScalar; - enum { - IsLower = (Mode & Lower) ==Lower, - HasUnitDiag = (Mode & UnitDiag)==UnitDiag, - HasZeroDiag = (Mode & ZeroDiag)==ZeroDiag - }; - static void run(Index size, const LhsScalar* lhs, const RhsScalar* rhs, ResScalar* res, ResScalar alpha) - { - internal::conj_if<ConjRhs> cj; - typedef Map<const Matrix<LhsScalar,Dynamic,1> > LhsMap; - typedef typename conj_expr_if<ConjLhs,LhsMap>::type ConjLhsType; - typedef Map<const Matrix<RhsScalar,Dynamic,1> > RhsMap; - typedef typename conj_expr_if<ConjRhs,RhsMap>::type ConjRhsType; - - for (Index i=0; i<size; ++i) - { - Index s = !IsLower&&(HasUnitDiag||HasZeroDiag) ? 1 : 0; - Index r = IsLower ? i+1 : size-i; - if (EIGEN_IMPLIES(HasUnitDiag||HasZeroDiag, (--r)>0)) - res[i] += alpha * (ConjLhsType(LhsMap(lhs+s,r)).cwiseProduct(ConjRhsType(RhsMap(rhs+(IsLower ? 0 : s+i),r)))).sum(); - if (HasUnitDiag) - res[i] += alpha * cj(rhs[i]); - lhs += IsLower ? i+1 : size-i; - } - }; -}; - -} // end namespace internal - -#endif // EIGEN_PACKED_TRIANGULAR_MATRIX_VECTOR_H diff --git a/eigen/blas/PackedTriangularSolverVector.h b/eigen/blas/PackedTriangularSolverVector.h deleted file mode 100644 index 5c0bb4b..0000000 --- a/eigen/blas/PackedTriangularSolverVector.h +++ /dev/null @@ -1,88 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#ifndef EIGEN_PACKED_TRIANGULAR_SOLVER_VECTOR_H -#define EIGEN_PACKED_TRIANGULAR_SOLVER_VECTOR_H - -namespace internal { - -template<typename LhsScalar, typename RhsScalar, typename Index, int Side, int Mode, bool Conjugate, int StorageOrder> -struct packed_triangular_solve_vector; - -// forward and backward substitution, row-major, rhs is a vector -template<typename LhsScalar, typename RhsScalar, typename Index, int Mode, bool Conjugate> -struct packed_triangular_solve_vector<LhsScalar, RhsScalar, Index, OnTheLeft, Mode, Conjugate, RowMajor> -{ - enum { - IsLower = (Mode&Lower)==Lower - }; - static void run(Index size, const LhsScalar* lhs, RhsScalar* rhs) - { - internal::conj_if<Conjugate> cj; - typedef Map<const Matrix<LhsScalar,Dynamic,1> > LhsMap; - typedef typename conj_expr_if<Conjugate,LhsMap>::type ConjLhsType; - - lhs += IsLower ? 0 : (size*(size+1)>>1)-1; - for(Index pi=0; pi<size; ++pi) - { - Index i = IsLower ? pi : size-pi-1; - Index s = IsLower ? 0 : 1; - if (pi>0) - rhs[i] -= (ConjLhsType(LhsMap(lhs+s,pi)) - .cwiseProduct(Map<const Matrix<RhsScalar,Dynamic,1> >(rhs+(IsLower ? 0 : i+1),pi))).sum(); - if (!(Mode & UnitDiag)) - rhs[i] /= cj(lhs[IsLower ? i : 0]); - IsLower ? lhs += pi+1 : lhs -= pi+2; - } - } -}; - -// forward and backward substitution, column-major, rhs is a vector -template<typename LhsScalar, typename RhsScalar, typename Index, int Mode, bool Conjugate> -struct packed_triangular_solve_vector<LhsScalar, RhsScalar, Index, OnTheLeft, Mode, Conjugate, ColMajor> -{ - enum { - IsLower = (Mode&Lower)==Lower - }; - static void run(Index size, const LhsScalar* lhs, RhsScalar* rhs) - { - internal::conj_if<Conjugate> cj; - typedef Map<const Matrix<LhsScalar,Dynamic,1> > LhsMap; - typedef typename conj_expr_if<Conjugate,LhsMap>::type ConjLhsType; - - lhs += IsLower ? 0 : size*(size-1)>>1; - for(Index pi=0; pi<size; ++pi) - { - Index i = IsLower ? pi : size-pi-1; - Index r = size - pi - 1; - if (!(Mode & UnitDiag)) - rhs[i] /= cj(lhs[IsLower ? 0 : i]); - if (r>0) - Map<Matrix<RhsScalar,Dynamic,1> >(rhs+(IsLower? i+1 : 0),r) -= - rhs[i] * ConjLhsType(LhsMap(lhs+(IsLower? 1 : 0),r)); - IsLower ? lhs += size-pi : lhs -= r; - } - } -}; - -template<typename LhsScalar, typename RhsScalar, typename Index, int Mode, bool Conjugate, int StorageOrder> -struct packed_triangular_solve_vector<LhsScalar, RhsScalar, Index, OnTheRight, Mode, Conjugate, StorageOrder> -{ - static void run(Index size, const LhsScalar* lhs, RhsScalar* rhs) - { - packed_triangular_solve_vector<LhsScalar,RhsScalar,Index,OnTheLeft, - ((Mode&Upper)==Upper ? Lower : Upper) | (Mode&UnitDiag), - Conjugate,StorageOrder==RowMajor?ColMajor:RowMajor - >::run(size, lhs, rhs); - } -}; - -} // end namespace internal - -#endif // EIGEN_PACKED_TRIANGULAR_SOLVER_VECTOR_H diff --git a/eigen/blas/README.txt b/eigen/blas/README.txt deleted file mode 100644 index 63a5203..0000000 --- a/eigen/blas/README.txt +++ /dev/null @@ -1,6 +0,0 @@ - -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. - diff --git a/eigen/blas/Rank2Update.h b/eigen/blas/Rank2Update.h deleted file mode 100644 index 138d70f..0000000 --- a/eigen/blas/Rank2Update.h +++ /dev/null @@ -1,57 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#ifndef EIGEN_RANK2UPDATE_H -#define EIGEN_RANK2UPDATE_H - -namespace internal { - -/* Optimized selfadjoint matrix += alpha * uv' + conj(alpha)*vu' - * This is the low-level version of SelfadjointRank2Update.h - */ -template<typename Scalar, typename Index, int UpLo> -struct rank2_update_selector -{ - static void run(Index size, Scalar* mat, Index stride, const Scalar* u, const Scalar* v, Scalar alpha) - { - typedef Map<const Matrix<Scalar,Dynamic,1> > OtherMap; - for (Index i=0; i<size; ++i) - { - Map<Matrix<Scalar,Dynamic,1> >(mat+stride*i+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1)) += - numext::conj(alpha) * numext::conj(u[i]) * OtherMap(v+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1)) - + alpha * numext::conj(v[i]) * OtherMap(u+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1)); - } - } -}; - -/* Optimized selfadjoint matrix += alpha * uv' + conj(alpha)*vu' - * The matrix is in packed form. - */ -template<typename Scalar, typename Index, int UpLo> -struct packed_rank2_update_selector -{ - static void run(Index size, Scalar* mat, const Scalar* u, const Scalar* v, Scalar alpha) - { - typedef Map<const Matrix<Scalar,Dynamic,1> > OtherMap; - Index offset = 0; - for (Index i=0; i<size; ++i) - { - Map<Matrix<Scalar,Dynamic,1> >(mat+offset, UpLo==Lower ? size-i : (i+1)) += - numext::conj(alpha) * numext::conj(u[i]) * OtherMap(v+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1)) - + alpha * numext::conj(v[i]) * OtherMap(u+(UpLo==Lower ? i : 0), UpLo==Lower ? size-i : (i+1)); - //FIXME This should be handled outside. - mat[offset+(UpLo==Lower ? 0 : i)] = numext::real(mat[offset+(UpLo==Lower ? 0 : i)]); - offset += UpLo==Lower ? size-i : (i+1); - } - } -}; - -} // end namespace internal - -#endif // EIGEN_RANK2UPDATE_H diff --git a/eigen/blas/common.h b/eigen/blas/common.h deleted file mode 100644 index 61d8344..0000000 --- a/eigen/blas/common.h +++ /dev/null @@ -1,163 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009-2015 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#ifndef EIGEN_BLAS_COMMON_H -#define EIGEN_BLAS_COMMON_H - -#include "../Eigen/Core" -#include "../Eigen/Jacobi" - -#include <complex> - -#ifndef SCALAR -#error the token SCALAR must be defined to compile this file -#endif - -#include "../Eigen/src/misc/blas.h" - -#define NOTR 0 -#define TR 1 -#define ADJ 2 - -#define LEFT 0 -#define RIGHT 1 - -#define UP 0 -#define LO 1 - -#define NUNIT 0 -#define UNIT 1 - -#define INVALID 0xff - -#define OP(X) ( ((X)=='N' || (X)=='n') ? NOTR \ - : ((X)=='T' || (X)=='t') ? TR \ - : ((X)=='C' || (X)=='c') ? ADJ \ - : INVALID) - -#define SIDE(X) ( ((X)=='L' || (X)=='l') ? LEFT \ - : ((X)=='R' || (X)=='r') ? RIGHT \ - : INVALID) - -#define UPLO(X) ( ((X)=='U' || (X)=='u') ? UP \ - : ((X)=='L' || (X)=='l') ? LO \ - : INVALID) - -#define DIAG(X) ( ((X)=='N' || (X)=='n') ? NUNIT \ - : ((X)=='U' || (X)=='u') ? UNIT \ - : INVALID) - - -inline bool check_op(const char* op) -{ - return OP(*op)!=0xff; -} - -inline bool check_side(const char* side) -{ - return SIDE(*side)!=0xff; -} - -inline bool check_uplo(const char* uplo) -{ - return UPLO(*uplo)!=0xff; -} - - -namespace Eigen { -#include "BandTriangularSolver.h" -#include "GeneralRank1Update.h" -#include "PackedSelfadjointProduct.h" -#include "PackedTriangularMatrixVector.h" -#include "PackedTriangularSolverVector.h" -#include "Rank2Update.h" -} - -using namespace Eigen; - -typedef SCALAR Scalar; -typedef NumTraits<Scalar>::Real RealScalar; -typedef std::complex<RealScalar> Complex; - -enum -{ - IsComplex = Eigen::NumTraits<SCALAR>::IsComplex, - Conj = IsComplex -}; - -typedef Matrix<Scalar,Dynamic,Dynamic,ColMajor> PlainMatrixType; -typedef Map<Matrix<Scalar,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> > MatrixType; -typedef Map<const Matrix<Scalar,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> > ConstMatrixType; -typedef Map<Matrix<Scalar,Dynamic,1>, 0, InnerStride<Dynamic> > StridedVectorType; -typedef Map<Matrix<Scalar,Dynamic,1> > CompactVectorType; - -template<typename T> -Map<Matrix<T,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> > -matrix(T* data, int rows, int cols, int stride) -{ - return Map<Matrix<T,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> >(data, rows, cols, OuterStride<>(stride)); -} - -template<typename T> -Map<const Matrix<T,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> > -matrix(const T* data, int rows, int cols, int stride) -{ - return Map<const Matrix<T,Dynamic,Dynamic,ColMajor>, 0, OuterStride<> >(data, rows, cols, OuterStride<>(stride)); -} - -template<typename T> -Map<Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> > make_vector(T* data, int size, int incr) -{ - return Map<Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> >(data, size, InnerStride<Dynamic>(incr)); -} - -template<typename T> -Map<const Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> > make_vector(const T* data, int size, int incr) -{ - return Map<const Matrix<T,Dynamic,1>, 0, InnerStride<Dynamic> >(data, size, InnerStride<Dynamic>(incr)); -} - -template<typename T> -Map<Matrix<T,Dynamic,1> > make_vector(T* data, int size) -{ - return Map<Matrix<T,Dynamic,1> >(data, size); -} - -template<typename T> -Map<const Matrix<T,Dynamic,1> > make_vector(const T* data, int size) -{ - return Map<const Matrix<T,Dynamic,1> >(data, size); -} - -template<typename T> -T* get_compact_vector(T* x, int n, int incx) -{ - if(incx==1) - return x; - - typename Eigen::internal::remove_const<T>::type* ret = new Scalar[n]; - if(incx<0) make_vector(ret,n) = make_vector(x,n,-incx).reverse(); - else make_vector(ret,n) = make_vector(x,n, incx); - return ret; -} - -template<typename T> -T* copy_back(T* x_cpy, T* x, int n, int incx) -{ - if(x_cpy==x) - return 0; - - if(incx<0) make_vector(x,n,-incx).reverse() = make_vector(x_cpy,n); - else make_vector(x,n, incx) = make_vector(x_cpy,n); - return x_cpy; -} - -#define EIGEN_BLAS_FUNC(X) EIGEN_CAT(SCALAR_SUFFIX,X##_) - -#endif // EIGEN_BLAS_COMMON_H diff --git a/eigen/blas/complex_double.cpp b/eigen/blas/complex_double.cpp deleted file mode 100644 index 648c6d4..0000000 --- a/eigen/blas/complex_double.cpp +++ /dev/null @@ -1,20 +0,0 @@ -// 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" diff --git a/eigen/blas/complex_single.cpp b/eigen/blas/complex_single.cpp deleted file mode 100644 index 7786519..0000000 --- a/eigen/blas/complex_single.cpp +++ /dev/null @@ -1,20 +0,0 @@ -// 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" diff --git a/eigen/blas/double.cpp b/eigen/blas/double.cpp deleted file mode 100644 index 295b1d1..0000000 --- a/eigen/blas/double.cpp +++ /dev/null @@ -1,32 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009 Gael Guennebaud <gael.guennebaud@inria.fr> -// Copyright (C) 2012 Chen-Pang He <jdh8@ms63.hinet.net> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#define SCALAR double -#define SCALAR_SUFFIX d -#define SCALAR_SUFFIX_UP "D" -#define ISCOMPLEX 0 - -#include "level1_impl.h" -#include "level1_real_impl.h" -#include "level2_impl.h" -#include "level2_real_impl.h" -#include "level3_impl.h" - -double BLASFUNC(dsdot)(int* n, float* x, int* incx, float* y, int* incy) -{ - if(*n<=0) return 0; - - if(*incx==1 && *incy==1) return (make_vector(x,*n).cast<double>().cwiseProduct(make_vector(y,*n).cast<double>())).sum(); - else if(*incx>0 && *incy>0) return (make_vector(x,*n,*incx).cast<double>().cwiseProduct(make_vector(y,*n,*incy).cast<double>())).sum(); - else if(*incx<0 && *incy>0) return (make_vector(x,*n,-*incx).reverse().cast<double>().cwiseProduct(make_vector(y,*n,*incy).cast<double>())).sum(); - else if(*incx>0 && *incy<0) return (make_vector(x,*n,*incx).cast<double>().cwiseProduct(make_vector(y,*n,-*incy).reverse().cast<double>())).sum(); - else if(*incx<0 && *incy<0) return (make_vector(x,*n,-*incx).reverse().cast<double>().cwiseProduct(make_vector(y,*n,-*incy).reverse().cast<double>())).sum(); - else return 0; -} diff --git a/eigen/blas/f2c/chbmv.c b/eigen/blas/f2c/chbmv.c deleted file mode 100644 index f218fe3..0000000 --- a/eigen/blas/f2c/chbmv.c +++ /dev/null @@ -1,487 +0,0 @@ -/* chbmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex * - alpha, complex *a, integer *lda, complex *x, integer *incx, complex * - beta, complex *y, integer *incy, ftnlen uplo_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - real r__1; - complex q__1, q__2, q__3, q__4; - - /* Builtin functions */ - void r_cnjg(complex *, complex *); - - /* Local variables */ - integer i__, j, l, ix, iy, jx, jy, kx, ky, info; - complex temp1, temp2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer kplus1; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* CHBMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n hermitian band matrix, with k super-diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the band matrix A is being supplied as */ -/* follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* being supplied. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* being supplied. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry, K specifies the number of super-diagonals of the */ -/* matrix A. K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* ALPHA - COMPLEX . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - COMPLEX array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the hermitian matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer the upper */ -/* triangular part of a hermitian band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the hermitian matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer the lower */ -/* triangular part of a hermitian band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Note that the imaginary parts of the diagonal elements need */ -/* not be set and are assumed to be zero. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. LDA must be at least */ -/* ( k + 1 ). */ -/* Unchanged on exit. */ - -/* X - COMPLEX array of DIMENSION at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the */ -/* vector x. */ -/* Unchanged on exit. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* BETA - COMPLEX . */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* Y - COMPLEX array of DIMENSION at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the */ -/* vector y. On exit, Y is overwritten by the updated vector y. */ - -/* INCY - INTEGER. */ -/* On entry, INCY specifies the increment for the elements of */ -/* Y. INCY must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*k < 0) { - info = 3; - } else if (*lda < *k + 1) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("CHBMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && - beta->i == 0.f))) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array A */ -/* are accessed sequentially with one pass through A. */ - -/* First form y := beta*y. */ - - if (beta->r != 1.f || beta->i != 0.f) { - if (*incy == 1) { - if (beta->r == 0.f && beta->i == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - y[i__2].r = 0.f, y[i__2].i = 0.f; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; -/* L20: */ - } - } - } else { - iy = ky; - if (beta->r == 0.f && beta->i == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - y[i__2].r = 0.f, y[i__2].i = 0.f; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - i__3 = iy; - q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - iy += *incy; -/* L40: */ - } - } - } - } - if (alpha->r == 0.f && alpha->i == 0.f) { - return 0; - } - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - -/* Form y when upper triangle of A is stored. */ - - kplus1 = *k + 1; - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = q__1.r, temp1.i = q__1.i; - temp2.r = 0.f, temp2.i = 0.f; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - i__2 = i__; - i__3 = i__; - i__5 = l + i__ + j * a_dim1; - q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); - i__2 = i__; - q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__2.i = - q__3.r * x[i__2].i + q__3.i * x[i__2].r; - q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; - temp2.r = q__1.r, temp2.i = q__1.i; -/* L50: */ - } - i__4 = j; - i__2 = j; - i__3 = kplus1 + j * a_dim1; - r__1 = a[i__3].r; - q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; - q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i; - q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; - y[i__4].r = q__1.r, y[i__4].i = q__1.i; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__4 = jx; - q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i = - alpha->r * x[i__4].i + alpha->i * x[i__4].r; - temp1.r = q__1.r, temp1.i = q__1.i; - temp2.r = 0.f, temp2.i = 0.f; - ix = kx; - iy = ky; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - i__4 = iy; - i__2 = iy; - i__5 = l + i__ + j * a_dim1; - q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i; - y[i__4].r = q__1.r, y[i__4].i = q__1.i; - r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); - i__4 = ix; - q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = - q__3.r * x[i__4].i + q__3.i * x[i__4].r; - q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; - temp2.r = q__1.r, temp2.i = q__1.i; - ix += *incx; - iy += *incy; -/* L70: */ - } - i__3 = jy; - i__4 = jy; - i__2 = kplus1 + j * a_dim1; - r__1 = a[i__2].r; - q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; - q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i; - q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; - jx += *incx; - jy += *incy; - if (j > *k) { - kx += *incx; - ky += *incy; - } -/* L80: */ - } - } - } else { - -/* Form y when lower triangle of A is stored. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__3 = j; - q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i = - alpha->r * x[i__3].i + alpha->i * x[i__3].r; - temp1.r = q__1.r, temp1.i = q__1.i; - temp2.r = 0.f, temp2.i = 0.f; - i__3 = j; - i__4 = j; - i__2 = j * a_dim1 + 1; - r__1 = a[i__2].r; - q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; - q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__2 = i__; - i__5 = l + i__ + j * a_dim1; - q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i; - y[i__4].r = q__1.r, y[i__4].i = q__1.i; - r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); - i__4 = i__; - q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = - q__3.r * x[i__4].i + q__3.i * x[i__4].r; - q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; - temp2.r = q__1.r, temp2.i = q__1.i; -/* L90: */ - } - i__3 = j; - i__4 = j; - q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__3 = jx; - q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i = - alpha->r * x[i__3].i + alpha->i * x[i__3].r; - temp1.r = q__1.r, temp1.i = q__1.i; - temp2.r = 0.f, temp2.i = 0.f; - i__3 = jy; - i__4 = jy; - i__2 = j * a_dim1 + 1; - r__1 = a[i__2].r; - q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; - q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; - l = 1 - j; - ix = jx; - iy = jy; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - ix += *incx; - iy += *incy; - i__4 = iy; - i__2 = iy; - i__5 = l + i__ + j * a_dim1; - q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i; - y[i__4].r = q__1.r, y[i__4].i = q__1.i; - r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); - i__4 = ix; - q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = - q__3.r * x[i__4].i + q__3.i * x[i__4].r; - q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; - temp2.r = q__1.r, temp2.i = q__1.i; -/* L110: */ - } - i__3 = jy; - i__4 = jy; - q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of CHBMV . */ - -} /* chbmv_ */ - diff --git a/eigen/blas/f2c/chpmv.c b/eigen/blas/f2c/chpmv.c deleted file mode 100644 index 65bab1c..0000000 --- a/eigen/blas/f2c/chpmv.c +++ /dev/null @@ -1,438 +0,0 @@ -/* chpmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int chpmv_(char *uplo, integer *n, complex *alpha, complex * - ap, complex *x, integer *incx, complex *beta, complex *y, integer * - incy, ftnlen uplo_len) -{ - /* System generated locals */ - integer i__1, i__2, i__3, i__4, i__5; - real r__1; - complex q__1, q__2, q__3, q__4; - - /* Builtin functions */ - void r_cnjg(complex *, complex *); - - /* Local variables */ - integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; - complex temp1, temp2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* CHPMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n hermitian matrix, supplied in packed form. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the matrix A is supplied in the packed */ -/* array AP as follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* supplied in AP. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* supplied in AP. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - COMPLEX . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* AP - COMPLEX array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular part of the hermitian matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ -/* and a( 2, 2 ) respectively, and so on. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular part of the hermitian matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ -/* and a( 3, 1 ) respectively, and so on. */ -/* Note that the imaginary parts of the diagonal elements need */ -/* not be set and are assumed to be zero. */ -/* Unchanged on exit. */ - -/* X - COMPLEX array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. */ -/* Unchanged on exit. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* BETA - COMPLEX . */ -/* On entry, BETA specifies the scalar beta. When BETA is */ -/* supplied as zero then Y need not be set on input. */ -/* Unchanged on exit. */ - -/* Y - COMPLEX array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the n */ -/* element vector y. On exit, Y is overwritten by the updated */ -/* vector y. */ - -/* INCY - INTEGER. */ -/* On entry, INCY specifies the increment for the elements of */ -/* Y. INCY must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --y; - --x; - --ap; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 6; - } else if (*incy == 0) { - info = 9; - } - if (info != 0) { - xerbla_("CHPMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && - beta->i == 0.f))) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array AP */ -/* are accessed sequentially with one pass through AP. */ - -/* First form y := beta*y. */ - - if (beta->r != 1.f || beta->i != 0.f) { - if (*incy == 1) { - if (beta->r == 0.f && beta->i == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - y[i__2].r = 0.f, y[i__2].i = 0.f; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; -/* L20: */ - } - } - } else { - iy = ky; - if (beta->r == 0.f && beta->i == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - y[i__2].r = 0.f, y[i__2].i = 0.f; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - i__3 = iy; - q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - iy += *incy; -/* L40: */ - } - } - } - } - if (alpha->r == 0.f && alpha->i == 0.f) { - return 0; - } - kk = 1; - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - -/* Form y when AP contains the upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = q__1.r, temp1.i = q__1.i; - temp2.r = 0.f, temp2.i = 0.f; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = k; - q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, - q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] - .r; - q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; - r_cnjg(&q__3, &ap[k]); - i__3 = i__; - q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = - q__3.r * x[i__3].i + q__3.i * x[i__3].r; - q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; - temp2.r = q__1.r, temp2.i = q__1.i; - ++k; -/* L50: */ - } - i__2 = j; - i__3 = j; - i__4 = kk + j - 1; - r__1 = ap[i__4].r; - q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; - q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; - q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - kk += j; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = q__1.r, temp1.i = q__1.i; - temp2.r = 0.f, temp2.i = 0.f; - ix = kx; - iy = ky; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - i__3 = iy; - i__4 = iy; - i__5 = k; - q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, - q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] - .r; - q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; - r_cnjg(&q__3, &ap[k]); - i__3 = ix; - q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = - q__3.r * x[i__3].i + q__3.i * x[i__3].r; - q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; - temp2.r = q__1.r, temp2.i = q__1.i; - ix += *incx; - iy += *incy; -/* L70: */ - } - i__2 = jy; - i__3 = jy; - i__4 = kk + j - 1; - r__1 = ap[i__4].r; - q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; - q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; - q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - jx += *incx; - jy += *incy; - kk += j; -/* L80: */ - } - } - } else { - -/* Form y when AP contains the lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = q__1.r, temp1.i = q__1.i; - temp2.r = 0.f, temp2.i = 0.f; - i__2 = j; - i__3 = j; - i__4 = kk; - r__1 = ap[i__4].r; - q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; - q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = k; - q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, - q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] - .r; - q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; - r_cnjg(&q__3, &ap[k]); - i__3 = i__; - q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = - q__3.r * x[i__3].i + q__3.i * x[i__3].r; - q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; - temp2.r = q__1.r, temp2.i = q__1.i; - ++k; -/* L90: */ - } - i__2 = j; - i__3 = j; - q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - kk += *n - j + 1; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = q__1.r, temp1.i = q__1.i; - temp2.r = 0.f, temp2.i = 0.f; - i__2 = jy; - i__3 = jy; - i__4 = kk; - r__1 = ap[i__4].r; - q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; - q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - ix = jx; - iy = jy; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - iy += *incy; - i__3 = iy; - i__4 = iy; - i__5 = k; - q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, - q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] - .r; - q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; - y[i__3].r = q__1.r, y[i__3].i = q__1.i; - r_cnjg(&q__3, &ap[k]); - i__3 = ix; - q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = - q__3.r * x[i__3].i + q__3.i * x[i__3].r; - q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; - temp2.r = q__1.r, temp2.i = q__1.i; -/* L110: */ - } - i__2 = jy; - i__3 = jy; - q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; - y[i__2].r = q__1.r, y[i__2].i = q__1.i; - jx += *incx; - jy += *incy; - kk += *n - j + 1; -/* L120: */ - } - } - } - - return 0; - -/* End of CHPMV . */ - -} /* chpmv_ */ - diff --git a/eigen/blas/f2c/complexdots.c b/eigen/blas/f2c/complexdots.c deleted file mode 100644 index a856a23..0000000 --- a/eigen/blas/f2c/complexdots.c +++ /dev/null @@ -1,84 +0,0 @@ -/* This file has been modified to use the standard gfortran calling - convention, rather than the f2c calling convention. - - It does not require -ff2c when compiled with gfortran. -*/ - -/* complexdots.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -complex cdotc_(integer *n, complex *cx, integer - *incx, complex *cy, integer *incy) -{ - complex res; - extern /* Subroutine */ int cdotcw_(integer *, complex *, integer *, - complex *, integer *, complex *); - - /* Parameter adjustments */ - --cy; - --cx; - - /* Function Body */ - cdotcw_(n, &cx[1], incx, &cy[1], incy, &res); - return res; -} /* cdotc_ */ - -complex cdotu_(integer *n, complex *cx, integer - *incx, complex *cy, integer *incy) -{ - complex res; - extern /* Subroutine */ int cdotuw_(integer *, complex *, integer *, - complex *, integer *, complex *); - - /* Parameter adjustments */ - --cy; - --cx; - - /* Function Body */ - cdotuw_(n, &cx[1], incx, &cy[1], incy, &res); - return res; -} /* cdotu_ */ - -doublecomplex zdotc_(integer *n, doublecomplex *cx, integer *incx, - doublecomplex *cy, integer *incy) -{ - doublecomplex res; - extern /* Subroutine */ int zdotcw_(integer *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *); - - /* Parameter adjustments */ - --cy; - --cx; - - /* Function Body */ - zdotcw_(n, &cx[1], incx, &cy[1], incy, &res); - return res; -} /* zdotc_ */ - -doublecomplex zdotu_(integer *n, doublecomplex *cx, integer *incx, - doublecomplex *cy, integer *incy) -{ - doublecomplex res; - extern /* Subroutine */ int zdotuw_(integer *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *); - - /* Parameter adjustments */ - --cy; - --cx; - - /* Function Body */ - zdotuw_(n, &cx[1], incx, &cy[1], incy, &res); - return res; -} /* zdotu_ */ - diff --git a/eigen/blas/f2c/ctbmv.c b/eigen/blas/f2c/ctbmv.c deleted file mode 100644 index 790fd58..0000000 --- a/eigen/blas/f2c/ctbmv.c +++ /dev/null @@ -1,647 +0,0 @@ -/* ctbmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int ctbmv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, complex *a, integer *lda, complex *x, integer *incx, - ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - complex q__1, q__2, q__3; - - /* Builtin functions */ - void r_cnjg(complex *, complex *); - - /* Local variables */ - integer i__, j, l, ix, jx, kx, info; - complex temp; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer kplus1; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - logical noconj, nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* CTBMV performs one of the matrix-vector operations */ - -/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ - -/* where x is an n element vector and A is an n by n unit, or non-unit, */ -/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' x := A*x. */ - -/* TRANS = 'T' or 't' x := A'*x. */ - -/* TRANS = 'C' or 'c' x := conjg( A' )*x. */ - -/* Unchanged on exit. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit */ -/* triangular as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with UPLO = 'U' or 'u', K specifies the number of */ -/* super-diagonals of the matrix A. */ -/* On entry with UPLO = 'L' or 'l', K specifies the number of */ -/* sub-diagonals of the matrix A. */ -/* K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* A - COMPLEX array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer an upper */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer a lower */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Note that when DIAG = 'U' or 'u' the elements of the array A */ -/* corresponding to the diagonal elements of the matrix are not */ -/* referenced, but are assumed to be unity. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. LDA must be at least */ -/* ( k + 1 ). */ -/* Unchanged on exit. */ - -/* X - COMPLEX array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. On exit, X is overwritten with the */ -/* tranformed vector x. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - "N", (ftnlen)1, (ftnlen)1)) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < *k + 1) { - info = 7; - } else if (*incx == 0) { - info = 9; - } - if (info != 0) { - xerbla_("CTBMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1); - nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); - -/* Set up the start point in X if the increment is not unity. This */ -/* will be ( N - 1 )*INCX too small for descending loops. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) { - -/* Form x := A*x. */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - kplus1 = *k + 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - if (x[i__2].r != 0.f || x[i__2].i != 0.f) { - i__2 = j; - temp.r = x[i__2].r, temp.i = x[i__2].i; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - i__2 = i__; - i__3 = i__; - i__5 = l + i__ + j * a_dim1; - q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, - q__2.i = temp.r * a[i__5].i + temp.i * a[ - i__5].r; - q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + - q__2.i; - x[i__2].r = q__1.r, x[i__2].i = q__1.i; -/* L10: */ - } - if (nounit) { - i__4 = j; - i__2 = j; - i__3 = kplus1 + j * a_dim1; - q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ - i__3].i, q__1.i = x[i__2].r * a[i__3].i + - x[i__2].i * a[i__3].r; - x[i__4].r = q__1.r, x[i__4].i = q__1.i; - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__4 = jx; - if (x[i__4].r != 0.f || x[i__4].i != 0.f) { - i__4 = jx; - temp.r = x[i__4].r, temp.i = x[i__4].i; - ix = kx; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - i__4 = ix; - i__2 = ix; - i__5 = l + i__ + j * a_dim1; - q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, - q__2.i = temp.r * a[i__5].i + temp.i * a[ - i__5].r; - q__1.r = x[i__2].r + q__2.r, q__1.i = x[i__2].i + - q__2.i; - x[i__4].r = q__1.r, x[i__4].i = q__1.i; - ix += *incx; -/* L30: */ - } - if (nounit) { - i__3 = jx; - i__4 = jx; - i__2 = kplus1 + j * a_dim1; - q__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[ - i__2].i, q__1.i = x[i__4].r * a[i__2].i + - x[i__4].i * a[i__2].r; - x[i__3].r = q__1.r, x[i__3].i = q__1.i; - } - } - jx += *incx; - if (j > *k) { - kx += *incx; - } -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__1 = j; - if (x[i__1].r != 0.f || x[i__1].i != 0.f) { - i__1 = j; - temp.r = x[i__1].r, temp.i = x[i__1].i; - l = 1 - j; -/* Computing MIN */ - i__1 = *n, i__3 = j + *k; - i__4 = j + 1; - for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { - i__1 = i__; - i__3 = i__; - i__2 = l + i__ + j * a_dim1; - q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, - q__2.i = temp.r * a[i__2].i + temp.i * a[ - i__2].r; - q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + - q__2.i; - x[i__1].r = q__1.r, x[i__1].i = q__1.i; -/* L50: */ - } - if (nounit) { - i__4 = j; - i__1 = j; - i__3 = j * a_dim1 + 1; - q__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[ - i__3].i, q__1.i = x[i__1].r * a[i__3].i + - x[i__1].i * a[i__3].r; - x[i__4].r = q__1.r, x[i__4].i = q__1.i; - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - i__4 = jx; - if (x[i__4].r != 0.f || x[i__4].i != 0.f) { - i__4 = jx; - temp.r = x[i__4].r, temp.i = x[i__4].i; - ix = kx; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__1 = j + *k; - i__3 = j + 1; - for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { - i__4 = ix; - i__1 = ix; - i__2 = l + i__ + j * a_dim1; - q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, - q__2.i = temp.r * a[i__2].i + temp.i * a[ - i__2].r; - q__1.r = x[i__1].r + q__2.r, q__1.i = x[i__1].i + - q__2.i; - x[i__4].r = q__1.r, x[i__4].i = q__1.i; - ix -= *incx; -/* L70: */ - } - if (nounit) { - i__3 = jx; - i__4 = jx; - i__1 = j * a_dim1 + 1; - q__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[ - i__1].i, q__1.i = x[i__4].r * a[i__1].i + - x[i__4].i * a[i__1].r; - x[i__3].r = q__1.r, x[i__3].i = q__1.i; - } - } - jx -= *incx; - if (*n - j >= *k) { - kx -= *incx; - } -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x or x := conjg( A' )*x. */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - kplus1 = *k + 1; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__3 = j; - temp.r = x[i__3].r, temp.i = x[i__3].i; - l = kplus1 - j; - if (noconj) { - if (nounit) { - i__3 = kplus1 + j * a_dim1; - q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, - q__1.i = temp.r * a[i__3].i + temp.i * a[ - i__3].r; - temp.r = q__1.r, temp.i = q__1.i; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - i__4 = l + i__ + j * a_dim1; - i__1 = i__; - q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ - i__1].i, q__2.i = a[i__4].r * x[i__1].i + - a[i__4].i * x[i__1].r; - q__1.r = temp.r + q__2.r, q__1.i = temp.i + - q__2.i; - temp.r = q__1.r, temp.i = q__1.i; -/* L90: */ - } - } else { - if (nounit) { - r_cnjg(&q__2, &a[kplus1 + j * a_dim1]); - q__1.r = temp.r * q__2.r - temp.i * q__2.i, - q__1.i = temp.r * q__2.i + temp.i * - q__2.r; - temp.r = q__1.r, temp.i = q__1.i; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); - i__4 = i__; - q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, - q__2.i = q__3.r * x[i__4].i + q__3.i * x[ - i__4].r; - q__1.r = temp.r + q__2.r, q__1.i = temp.i + - q__2.i; - temp.r = q__1.r, temp.i = q__1.i; -/* L100: */ - } - } - i__3 = j; - x[i__3].r = temp.r, x[i__3].i = temp.i; -/* L110: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - i__3 = jx; - temp.r = x[i__3].r, temp.i = x[i__3].i; - kx -= *incx; - ix = kx; - l = kplus1 - j; - if (noconj) { - if (nounit) { - i__3 = kplus1 + j * a_dim1; - q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, - q__1.i = temp.r * a[i__3].i + temp.i * a[ - i__3].r; - temp.r = q__1.r, temp.i = q__1.i; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - i__4 = l + i__ + j * a_dim1; - i__1 = ix; - q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ - i__1].i, q__2.i = a[i__4].r * x[i__1].i + - a[i__4].i * x[i__1].r; - q__1.r = temp.r + q__2.r, q__1.i = temp.i + - q__2.i; - temp.r = q__1.r, temp.i = q__1.i; - ix -= *incx; -/* L120: */ - } - } else { - if (nounit) { - r_cnjg(&q__2, &a[kplus1 + j * a_dim1]); - q__1.r = temp.r * q__2.r - temp.i * q__2.i, - q__1.i = temp.r * q__2.i + temp.i * - q__2.r; - temp.r = q__1.r, temp.i = q__1.i; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); - i__4 = ix; - q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, - q__2.i = q__3.r * x[i__4].i + q__3.i * x[ - i__4].r; - q__1.r = temp.r + q__2.r, q__1.i = temp.i + - q__2.i; - temp.r = q__1.r, temp.i = q__1.i; - ix -= *incx; -/* L130: */ - } - } - i__3 = jx; - x[i__3].r = temp.r, x[i__3].i = temp.i; - jx -= *incx; -/* L140: */ - } - } - } else { - if (*incx == 1) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - i__4 = j; - temp.r = x[i__4].r, temp.i = x[i__4].i; - l = 1 - j; - if (noconj) { - if (nounit) { - i__4 = j * a_dim1 + 1; - q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, - q__1.i = temp.r * a[i__4].i + temp.i * a[ - i__4].r; - temp.r = q__1.r, temp.i = q__1.i; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - i__1 = l + i__ + j * a_dim1; - i__2 = i__; - q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ - i__2].i, q__2.i = a[i__1].r * x[i__2].i + - a[i__1].i * x[i__2].r; - q__1.r = temp.r + q__2.r, q__1.i = temp.i + - q__2.i; - temp.r = q__1.r, temp.i = q__1.i; -/* L150: */ - } - } else { - if (nounit) { - r_cnjg(&q__2, &a[j * a_dim1 + 1]); - q__1.r = temp.r * q__2.r - temp.i * q__2.i, - q__1.i = temp.r * q__2.i + temp.i * - q__2.r; - temp.r = q__1.r, temp.i = q__1.i; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); - i__1 = i__; - q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, - q__2.i = q__3.r * x[i__1].i + q__3.i * x[ - i__1].r; - q__1.r = temp.r + q__2.r, q__1.i = temp.i + - q__2.i; - temp.r = q__1.r, temp.i = q__1.i; -/* L160: */ - } - } - i__4 = j; - x[i__4].r = temp.r, x[i__4].i = temp.i; -/* L170: */ - } - } else { - jx = kx; - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - i__4 = jx; - temp.r = x[i__4].r, temp.i = x[i__4].i; - kx += *incx; - ix = kx; - l = 1 - j; - if (noconj) { - if (nounit) { - i__4 = j * a_dim1 + 1; - q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, - q__1.i = temp.r * a[i__4].i + temp.i * a[ - i__4].r; - temp.r = q__1.r, temp.i = q__1.i; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - i__1 = l + i__ + j * a_dim1; - i__2 = ix; - q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ - i__2].i, q__2.i = a[i__1].r * x[i__2].i + - a[i__1].i * x[i__2].r; - q__1.r = temp.r + q__2.r, q__1.i = temp.i + - q__2.i; - temp.r = q__1.r, temp.i = q__1.i; - ix += *incx; -/* L180: */ - } - } else { - if (nounit) { - r_cnjg(&q__2, &a[j * a_dim1 + 1]); - q__1.r = temp.r * q__2.r - temp.i * q__2.i, - q__1.i = temp.r * q__2.i + temp.i * - q__2.r; - temp.r = q__1.r, temp.i = q__1.i; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); - i__1 = ix; - q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, - q__2.i = q__3.r * x[i__1].i + q__3.i * x[ - i__1].r; - q__1.r = temp.r + q__2.r, q__1.i = temp.i + - q__2.i; - temp.r = q__1.r, temp.i = q__1.i; - ix += *incx; -/* L190: */ - } - } - i__4 = jx; - x[i__4].r = temp.r, x[i__4].i = temp.i; - jx += *incx; -/* L200: */ - } - } - } - } - - return 0; - -/* End of CTBMV . */ - -} /* ctbmv_ */ - diff --git a/eigen/blas/f2c/d_cnjg.c b/eigen/blas/f2c/d_cnjg.c deleted file mode 100644 index 623090c..0000000 --- a/eigen/blas/f2c/d_cnjg.c +++ /dev/null @@ -1,6 +0,0 @@ -#include "datatypes.h" - -void d_cnjg(doublecomplex *r, doublecomplex *z) { - r->r = z->r; - r->i = -(z->i); -} diff --git a/eigen/blas/f2c/datatypes.h b/eigen/blas/f2c/datatypes.h deleted file mode 100644 index 63232b2..0000000 --- a/eigen/blas/f2c/datatypes.h +++ /dev/null @@ -1,24 +0,0 @@ -/* This contains a limited subset of the typedefs exposed by f2c - for use by the Eigen BLAS C-only implementation. -*/ - -#ifndef __EIGEN_DATATYPES_H__ -#define __EIGEN_DATATYPES_H__ - -typedef int integer; -typedef unsigned int uinteger; -typedef float real; -typedef double doublereal; -typedef struct { real r, i; } complex; -typedef struct { doublereal r, i; } doublecomplex; -typedef int ftnlen; -typedef int logical; - -#define abs(x) ((x) >= 0 ? (x) : -(x)) -#define dabs(x) (doublereal)abs(x) -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#define max(a,b) ((a) >= (b) ? (a) : (b)) -#define dmin(a,b) (doublereal)min(a,b) -#define dmax(a,b) (doublereal)max(a,b) - -#endif diff --git a/eigen/blas/f2c/drotm.c b/eigen/blas/f2c/drotm.c deleted file mode 100644 index 17a779b..0000000 --- a/eigen/blas/f2c/drotm.c +++ /dev/null @@ -1,215 +0,0 @@ -/* drotm.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy, doublereal *dparam) -{ - /* Initialized data */ - - static doublereal zero = 0.; - static doublereal two = 2.; - - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__; - doublereal w, z__; - integer kx, ky; - doublereal dh11, dh12, dh21, dh22, dflag; - integer nsteps; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ - -/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */ -/* (DY**T) */ - -/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ -/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */ -/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ - -/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ - -/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ -/* H=( ) ( ) ( ) ( ) */ -/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ -/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* number of elements in input vector(s) */ - -/* DX (input/output) DOUBLE PRECISION array, dimension N */ -/* double precision vector with N elements */ - -/* INCX (input) INTEGER */ -/* storage spacing between elements of DX */ - -/* DY (input/output) DOUBLE PRECISION array, dimension N */ -/* double precision vector with N elements */ - -/* INCY (input) INTEGER */ -/* storage spacing between elements of DY */ - -/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ -/* DPARAM(1)=DFLAG */ -/* DPARAM(2)=DH11 */ -/* DPARAM(3)=DH21 */ -/* DPARAM(4)=DH12 */ -/* DPARAM(5)=DH22 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --dparam; - --dy; - --dx; - - /* Function Body */ -/* .. */ - - dflag = dparam[1]; - if (*n <= 0 || dflag + two == zero) { - goto L140; - } - if (! (*incx == *incy && *incx > 0)) { - goto L70; - } - - nsteps = *n * *incx; - if (dflag < 0.) { - goto L50; - } else if (dflag == 0) { - goto L10; - } else { - goto L30; - } -L10: - dh12 = dparam[4]; - dh21 = dparam[3]; - i__1 = nsteps; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w + z__ * dh12; - dy[i__] = w * dh21 + z__; -/* L20: */ - } - goto L140; -L30: - dh11 = dparam[2]; - dh22 = dparam[5]; - i__2 = nsteps; - i__1 = *incx; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w * dh11 + z__; - dy[i__] = -w + dh22 * z__; -/* L40: */ - } - goto L140; -L50: - dh11 = dparam[2]; - dh12 = dparam[4]; - dh21 = dparam[3]; - dh22 = dparam[5]; - i__1 = nsteps; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w * dh11 + z__ * dh12; - dy[i__] = w * dh21 + z__ * dh22; -/* L60: */ - } - goto L140; -L70: - kx = 1; - ky = 1; - if (*incx < 0) { - kx = (1 - *n) * *incx + 1; - } - if (*incy < 0) { - ky = (1 - *n) * *incy + 1; - } - - if (dflag < 0.) { - goto L120; - } else if (dflag == 0) { - goto L80; - } else { - goto L100; - } -L80: - dh12 = dparam[4]; - dh21 = dparam[3]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w + z__ * dh12; - dy[ky] = w * dh21 + z__; - kx += *incx; - ky += *incy; -/* L90: */ - } - goto L140; -L100: - dh11 = dparam[2]; - dh22 = dparam[5]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w * dh11 + z__; - dy[ky] = -w + dh22 * z__; - kx += *incx; - ky += *incy; -/* L110: */ - } - goto L140; -L120: - dh11 = dparam[2]; - dh12 = dparam[4]; - dh21 = dparam[3]; - dh22 = dparam[5]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w * dh11 + z__ * dh12; - dy[ky] = w * dh21 + z__ * dh22; - kx += *incx; - ky += *incy; -/* L130: */ - } -L140: - return 0; -} /* drotm_ */ - diff --git a/eigen/blas/f2c/drotmg.c b/eigen/blas/f2c/drotmg.c deleted file mode 100644 index a63eb10..0000000 --- a/eigen/blas/f2c/drotmg.c +++ /dev/null @@ -1,293 +0,0 @@ -/* drotmg.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal * - dx1, doublereal *dy1, doublereal *dparam) -{ - /* Initialized data */ - - static doublereal zero = 0.; - static doublereal one = 1.; - static doublereal two = 2.; - static doublereal gam = 4096.; - static doublereal gamsq = 16777216.; - static doublereal rgamsq = 5.9604645e-8; - - /* Format strings */ - static char fmt_120[] = ""; - static char fmt_150[] = ""; - static char fmt_180[] = ""; - static char fmt_210[] = ""; - - /* System generated locals */ - doublereal d__1; - - /* Local variables */ - doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22; - integer igo; - doublereal dflag, dtemp; - - /* Assigned format variables */ - static char *igo_fmt; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ -/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */ -/* DY2)**T. */ -/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ - -/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ - -/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ -/* H=( ) ( ) ( ) ( ) */ -/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ -/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */ -/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */ -/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */ - -/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ -/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ -/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ - - -/* Arguments */ -/* ========= */ - -/* DD1 (input/output) DOUBLE PRECISION */ - -/* DD2 (input/output) DOUBLE PRECISION */ - -/* DX1 (input/output) DOUBLE PRECISION */ - -/* DY1 (input) DOUBLE PRECISION */ - -/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ -/* DPARAM(1)=DFLAG */ -/* DPARAM(2)=DH11 */ -/* DPARAM(3)=DH21 */ -/* DPARAM(4)=DH12 */ -/* DPARAM(5)=DH22 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Data statements .. */ - - /* Parameter adjustments */ - --dparam; - - /* Function Body */ -/* .. */ - if (! (*dd1 < zero)) { - goto L10; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L10: -/* CASE-DD1-NONNEGATIVE */ - dp2 = *dd2 * *dy1; - if (! (dp2 == zero)) { - goto L20; - } - dflag = -two; - goto L260; -/* REGULAR-CASE.. */ -L20: - dp1 = *dd1 * *dx1; - dq2 = dp2 * *dy1; - dq1 = dp1 * *dx1; - - if (! (abs(dq1) > abs(dq2))) { - goto L40; - } - dh21 = -(*dy1) / *dx1; - dh12 = dp2 / dp1; - - du = one - dh12 * dh21; - - if (! (du <= zero)) { - goto L30; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L30: - dflag = zero; - *dd1 /= du; - *dd2 /= du; - *dx1 *= du; -/* GO SCALE-CHECK.. */ - goto L100; -L40: - if (! (dq2 < zero)) { - goto L50; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L50: - dflag = one; - dh11 = dp1 / dp2; - dh22 = *dx1 / *dy1; - du = one + dh11 * dh22; - dtemp = *dd2 / du; - *dd2 = *dd1 / du; - *dd1 = dtemp; - *dx1 = *dy1 * du; -/* GO SCALE-CHECK */ - goto L100; -/* PROCEDURE..ZERO-H-D-AND-DX1.. */ -L60: - dflag = -one; - dh11 = zero; - dh12 = zero; - dh21 = zero; - dh22 = zero; - - *dd1 = zero; - *dd2 = zero; - *dx1 = zero; -/* RETURN.. */ - goto L220; -/* PROCEDURE..FIX-H.. */ -L70: - if (! (dflag >= zero)) { - goto L90; - } - - if (! (dflag == zero)) { - goto L80; - } - dh11 = one; - dh22 = one; - dflag = -one; - goto L90; -L80: - dh21 = -one; - dh12 = one; - dflag = -one; -L90: - switch (igo) { - case 0: goto L120; - case 1: goto L150; - case 2: goto L180; - case 3: goto L210; - } -/* PROCEDURE..SCALE-CHECK */ -L100: -L110: - if (! (*dd1 <= rgamsq)) { - goto L130; - } - if (*dd1 == zero) { - goto L160; - } - igo = 0; - igo_fmt = fmt_120; -/* FIX-H.. */ - goto L70; -L120: -/* Computing 2nd power */ - d__1 = gam; - *dd1 *= d__1 * d__1; - *dx1 /= gam; - dh11 /= gam; - dh12 /= gam; - goto L110; -L130: -L140: - if (! (*dd1 >= gamsq)) { - goto L160; - } - igo = 1; - igo_fmt = fmt_150; -/* FIX-H.. */ - goto L70; -L150: -/* Computing 2nd power */ - d__1 = gam; - *dd1 /= d__1 * d__1; - *dx1 *= gam; - dh11 *= gam; - dh12 *= gam; - goto L140; -L160: -L170: - if (! (abs(*dd2) <= rgamsq)) { - goto L190; - } - if (*dd2 == zero) { - goto L220; - } - igo = 2; - igo_fmt = fmt_180; -/* FIX-H.. */ - goto L70; -L180: -/* Computing 2nd power */ - d__1 = gam; - *dd2 *= d__1 * d__1; - dh21 /= gam; - dh22 /= gam; - goto L170; -L190: -L200: - if (! (abs(*dd2) >= gamsq)) { - goto L220; - } - igo = 3; - igo_fmt = fmt_210; -/* FIX-H.. */ - goto L70; -L210: -/* Computing 2nd power */ - d__1 = gam; - *dd2 /= d__1 * d__1; - dh21 *= gam; - dh22 *= gam; - goto L200; -L220: - if (dflag < 0.) { - goto L250; - } else if (dflag == 0) { - goto L230; - } else { - goto L240; - } -L230: - dparam[3] = dh21; - dparam[4] = dh12; - goto L260; -L240: - dparam[2] = dh11; - dparam[5] = dh22; - goto L260; -L250: - dparam[2] = dh11; - dparam[3] = dh21; - dparam[4] = dh12; - dparam[5] = dh22; -L260: - dparam[1] = dflag; - return 0; -} /* drotmg_ */ - diff --git a/eigen/blas/f2c/dsbmv.c b/eigen/blas/f2c/dsbmv.c deleted file mode 100644 index c6b4b21..0000000 --- a/eigen/blas/f2c/dsbmv.c +++ /dev/null @@ -1,366 +0,0 @@ -/* dsbmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal * - alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, - doublereal *beta, doublereal *y, integer *incy, ftnlen uplo_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ix, iy, jx, jy, kx, ky, info; - doublereal temp1, temp2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer kplus1; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric band matrix, with k super-diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the band matrix A is being supplied as */ -/* follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* being supplied. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* being supplied. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry, K specifies the number of super-diagonals of the */ -/* matrix A. K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* ALPHA - DOUBLE PRECISION. */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the symmetric matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer the upper */ -/* triangular part of a symmetric band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the symmetric matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer the lower */ -/* triangular part of a symmetric band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. LDA must be at least */ -/* ( k + 1 ). */ -/* Unchanged on exit. */ - -/* X - DOUBLE PRECISION array of DIMENSION at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the */ -/* vector x. */ -/* Unchanged on exit. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* BETA - DOUBLE PRECISION. */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* Y - DOUBLE PRECISION array of DIMENSION at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the */ -/* vector y. On exit, Y is overwritten by the updated vector y. */ - -/* INCY - INTEGER. */ -/* On entry, INCY specifies the increment for the elements of */ -/* Y. INCY must not be zero. */ -/* Unchanged on exit. */ - - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*k < 0) { - info = 3; - } else if (*lda < *k + 1) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("DSBMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0. && *beta == 1.)) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array A */ -/* are accessed sequentially with one pass through A. */ - -/* First form y := beta*y. */ - - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - -/* Form y when upper triangle of A is stored. */ - - kplus1 = *k + 1; - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - y[i__] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[i__]; -/* L50: */ - } - y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - y[iy] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * - temp2; - jx += *incx; - jy += *incy; - if (j > *k) { - kx += *incx; - ky += *incy; - } -/* L80: */ - } - } - } else { - -/* Form y when lower triangle of A is stored. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * a[j * a_dim1 + 1]; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - y[i__] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[j] += *alpha * temp2; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * a[j * a_dim1 + 1]; - l = 1 - j; - ix = jx; - iy = jy; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of DSBMV . */ - -} /* dsbmv_ */ - diff --git a/eigen/blas/f2c/dspmv.c b/eigen/blas/f2c/dspmv.c deleted file mode 100644 index 0b4e92d..0000000 --- a/eigen/blas/f2c/dspmv.c +++ /dev/null @@ -1,316 +0,0 @@ -/* dspmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha, - doublereal *ap, doublereal *x, integer *incx, doublereal *beta, - doublereal *y, integer *incy, ftnlen uplo_len) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; - doublereal temp1, temp2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric matrix, supplied in packed form. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the matrix A is supplied in the packed */ -/* array AP as follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* supplied in AP. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* supplied in AP. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - DOUBLE PRECISION. */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* AP - DOUBLE PRECISION array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ -/* and a( 2, 2 ) respectively, and so on. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ -/* and a( 3, 1 ) respectively, and so on. */ -/* Unchanged on exit. */ - -/* X - DOUBLE PRECISION array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. */ -/* Unchanged on exit. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* BETA - DOUBLE PRECISION. */ -/* On entry, BETA specifies the scalar beta. When BETA is */ -/* supplied as zero then Y need not be set on input. */ -/* Unchanged on exit. */ - -/* Y - DOUBLE PRECISION array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the n */ -/* element vector y. On exit, Y is overwritten by the updated */ -/* vector y. */ - -/* INCY - INTEGER. */ -/* On entry, INCY specifies the increment for the elements of */ -/* Y. INCY must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --y; - --x; - --ap; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 6; - } else if (*incy == 0) { - info = 9; - } - if (info != 0) { - xerbla_("DSPMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0. && *beta == 1.)) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array AP */ -/* are accessed sequentially with one pass through AP. */ - -/* First form y := beta*y. */ - - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - kk = 1; - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - -/* Form y when AP contains the upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * ap[k]; - temp2 += ap[k] * x[i__]; - ++k; -/* L50: */ - } - y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; - kk += j; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - y[iy] += temp1 * ap[k]; - temp2 += ap[k] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; - jx += *incx; - jy += *incy; - kk += j; -/* L80: */ - } - } - } else { - -/* Form y when AP contains the lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * ap[kk]; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * ap[k]; - temp2 += ap[k] * x[i__]; - ++k; -/* L90: */ - } - y[j] += *alpha * temp2; - kk += *n - j + 1; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * ap[kk]; - ix = jx; - iy = jy; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * ap[k]; - temp2 += ap[k] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; - kk += *n - j + 1; -/* L120: */ - } - } - } - - return 0; - -/* End of DSPMV . */ - -} /* dspmv_ */ - diff --git a/eigen/blas/f2c/dtbmv.c b/eigen/blas/f2c/dtbmv.c deleted file mode 100644 index fdf73eb..0000000 --- a/eigen/blas/f2c/dtbmv.c +++ /dev/null @@ -1,428 +0,0 @@ -/* dtbmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx, - ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ix, jx, kx, info; - doublereal temp; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer kplus1; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - logical nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTBMV performs one of the matrix-vector operations */ - -/* x := A*x, or x := A'*x, */ - -/* where x is an n element vector and A is an n by n unit, or non-unit, */ -/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' x := A*x. */ - -/* TRANS = 'T' or 't' x := A'*x. */ - -/* TRANS = 'C' or 'c' x := A'*x. */ - -/* Unchanged on exit. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit */ -/* triangular as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with UPLO = 'U' or 'u', K specifies the number of */ -/* super-diagonals of the matrix A. */ -/* On entry with UPLO = 'L' or 'l', K specifies the number of */ -/* sub-diagonals of the matrix A. */ -/* K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer an upper */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer a lower */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Note that when DIAG = 'U' or 'u' the elements of the array A */ -/* corresponding to the diagonal elements of the matrix are not */ -/* referenced, but are assumed to be unity. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. LDA must be at least */ -/* ( k + 1 ). */ -/* Unchanged on exit. */ - -/* X - DOUBLE PRECISION array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. On exit, X is overwritten with the */ -/* tranformed vector x. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - "N", (ftnlen)1, (ftnlen)1)) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < *k + 1) { - info = 7; - } else if (*incx == 0) { - info = 9; - } - if (info != 0) { - xerbla_("DTBMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); - -/* Set up the start point in X if the increment is not unity. This */ -/* will be ( N - 1 )*INCX too small for descending loops. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) { - -/* Form x := A*x. */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - kplus1 = *k + 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - x[i__] += temp * a[l + i__ + j * a_dim1]; -/* L10: */ - } - if (nounit) { - x[j] *= a[kplus1 + j * a_dim1]; - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - x[ix] += temp * a[l + i__ + j * a_dim1]; - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= a[kplus1 + j * a_dim1]; - } - } - jx += *incx; - if (j > *k) { - kx += *incx; - } -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - l = 1 - j; -/* Computing MIN */ - i__1 = *n, i__3 = j + *k; - i__4 = j + 1; - for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { - x[i__] += temp * a[l + i__ + j * a_dim1]; -/* L50: */ - } - if (nounit) { - x[j] *= a[j * a_dim1 + 1]; - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__1 = j + *k; - i__3 = j + 1; - for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { - x[ix] += temp * a[l + i__ + j * a_dim1]; - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= a[j * a_dim1 + 1]; - } - } - jx -= *incx; - if (*n - j >= *k) { - kx -= *incx; - } -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x. */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - kplus1 = *k + 1; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - l = kplus1 - j; - if (nounit) { - temp *= a[kplus1 + j * a_dim1]; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - temp += a[l + i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - x[j] = temp; -/* L100: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - kx -= *incx; - ix = kx; - l = kplus1 - j; - if (nounit) { - temp *= a[kplus1 + j * a_dim1]; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - temp += a[l + i__ + j * a_dim1] * x[ix]; - ix -= *incx; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - temp = x[j]; - l = 1 - j; - if (nounit) { - temp *= a[j * a_dim1 + 1]; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - temp += a[l + i__ + j * a_dim1] * x[i__]; -/* L130: */ - } - x[j] = temp; -/* L140: */ - } - } else { - jx = kx; - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - temp = x[jx]; - kx += *incx; - ix = kx; - l = 1 - j; - if (nounit) { - temp *= a[j * a_dim1 + 1]; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - temp += a[l + i__ + j * a_dim1] * x[ix]; - ix += *incx; -/* L150: */ - } - x[jx] = temp; - jx += *incx; -/* L160: */ - } - } - } - } - - return 0; - -/* End of DTBMV . */ - -} /* dtbmv_ */ - diff --git a/eigen/blas/f2c/lsame.c b/eigen/blas/f2c/lsame.c deleted file mode 100644 index 46324d9..0000000 --- a/eigen/blas/f2c/lsame.c +++ /dev/null @@ -1,117 +0,0 @@ -/* lsame.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -logical lsame_(char *ca, char *cb, ftnlen ca_len, ftnlen cb_len) -{ - /* System generated locals */ - logical ret_val; - - /* Local variables */ - integer inta, intb, zcode; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* LSAME returns .TRUE. if CA is the same letter as CB regardless of */ -/* case. */ - -/* Arguments */ -/* ========= */ - -/* CA (input) CHARACTER*1 */ - -/* CB (input) CHARACTER*1 */ -/* CA and CB specify the single characters to be compared. */ - -/* ===================================================================== */ - -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ - -/* Test if the characters are equal */ - - ret_val = *(unsigned char *)ca == *(unsigned char *)cb; - if (ret_val) { - return ret_val; - } - -/* Now test for equivalence if both characters are alphabetic. */ - - zcode = 'Z'; - -/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */ -/* machines, on which ICHAR returns a value with bit 8 set. */ -/* ICHAR('A') on Prime machines returns 193 which is the same as */ -/* ICHAR('A') on an EBCDIC machine. */ - - inta = *(unsigned char *)ca; - intb = *(unsigned char *)cb; - - if (zcode == 90 || zcode == 122) { - -/* ASCII is assumed - ZCODE is the ASCII code of either lower or */ -/* upper case 'Z'. */ - - if (inta >= 97 && inta <= 122) { - inta += -32; - } - if (intb >= 97 && intb <= 122) { - intb += -32; - } - - } else if (zcode == 233 || zcode == 169) { - -/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */ -/* upper case 'Z'. */ - - if ((inta >= 129 && inta <= 137) || (inta >= 145 && inta <= 153) || - (inta >= 162 && inta <= 169)) { - inta += 64; - } - if ((intb >= 129 && intb <= 137) || (intb >= 145 && intb <= 153) || - (intb >= 162 && intb <= 169)) { - intb += 64; - } - - } else if (zcode == 218 || zcode == 250) { - -/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */ -/* plus 128 of either lower or upper case 'Z'. */ - - if (inta >= 225 && inta <= 250) { - inta += -32; - } - if (intb >= 225 && intb <= 250) { - intb += -32; - } - } - ret_val = inta == intb; - -/* RETURN */ - -/* End of LSAME */ - - return ret_val; -} /* lsame_ */ - diff --git a/eigen/blas/f2c/r_cnjg.c b/eigen/blas/f2c/r_cnjg.c deleted file mode 100644 index c08182f..0000000 --- a/eigen/blas/f2c/r_cnjg.c +++ /dev/null @@ -1,6 +0,0 @@ -#include "datatypes.h" - -void r_cnjg(complex *r, complex *z) { - r->r = z->r; - r->i = -(z->i); -} diff --git a/eigen/blas/f2c/srotm.c b/eigen/blas/f2c/srotm.c deleted file mode 100644 index bd5944a..0000000 --- a/eigen/blas/f2c/srotm.c +++ /dev/null @@ -1,216 +0,0 @@ -/* srotm.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy, - integer *incy, real *sparam) -{ - /* Initialized data */ - - static real zero = 0.f; - static real two = 2.f; - - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__; - real w, z__; - integer kx, ky; - real sh11, sh12, sh21, sh22, sflag; - integer nsteps; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ - -/* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */ -/* (DX**T) */ - -/* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ -/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */ -/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ - -/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ - -/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ -/* H=( ) ( ) ( ) ( ) */ -/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ -/* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */ - - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* number of elements in input vector(s) */ - -/* SX (input/output) REAL array, dimension N */ -/* double precision vector with N elements */ - -/* INCX (input) INTEGER */ -/* storage spacing between elements of SX */ - -/* SY (input/output) REAL array, dimension N */ -/* double precision vector with N elements */ - -/* INCY (input) INTEGER */ -/* storage spacing between elements of SY */ - -/* SPARAM (input/output) REAL array, dimension 5 */ -/* SPARAM(1)=SFLAG */ -/* SPARAM(2)=SH11 */ -/* SPARAM(3)=SH21 */ -/* SPARAM(4)=SH12 */ -/* SPARAM(5)=SH22 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --sparam; - --sy; - --sx; - - /* Function Body */ -/* .. */ - - sflag = sparam[1]; - if (*n <= 0 || sflag + two == zero) { - goto L140; - } - if (! (*incx == *incy && *incx > 0)) { - goto L70; - } - - nsteps = *n * *incx; - if (sflag < 0.f) { - goto L50; - } else if (sflag == 0) { - goto L10; - } else { - goto L30; - } -L10: - sh12 = sparam[4]; - sh21 = sparam[3]; - i__1 = nsteps; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - w = sx[i__]; - z__ = sy[i__]; - sx[i__] = w + z__ * sh12; - sy[i__] = w * sh21 + z__; -/* L20: */ - } - goto L140; -L30: - sh11 = sparam[2]; - sh22 = sparam[5]; - i__2 = nsteps; - i__1 = *incx; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { - w = sx[i__]; - z__ = sy[i__]; - sx[i__] = w * sh11 + z__; - sy[i__] = -w + sh22 * z__; -/* L40: */ - } - goto L140; -L50: - sh11 = sparam[2]; - sh12 = sparam[4]; - sh21 = sparam[3]; - sh22 = sparam[5]; - i__1 = nsteps; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - w = sx[i__]; - z__ = sy[i__]; - sx[i__] = w * sh11 + z__ * sh12; - sy[i__] = w * sh21 + z__ * sh22; -/* L60: */ - } - goto L140; -L70: - kx = 1; - ky = 1; - if (*incx < 0) { - kx = (1 - *n) * *incx + 1; - } - if (*incy < 0) { - ky = (1 - *n) * *incy + 1; - } - - if (sflag < 0.f) { - goto L120; - } else if (sflag == 0) { - goto L80; - } else { - goto L100; - } -L80: - sh12 = sparam[4]; - sh21 = sparam[3]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = sx[kx]; - z__ = sy[ky]; - sx[kx] = w + z__ * sh12; - sy[ky] = w * sh21 + z__; - kx += *incx; - ky += *incy; -/* L90: */ - } - goto L140; -L100: - sh11 = sparam[2]; - sh22 = sparam[5]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = sx[kx]; - z__ = sy[ky]; - sx[kx] = w * sh11 + z__; - sy[ky] = -w + sh22 * z__; - kx += *incx; - ky += *incy; -/* L110: */ - } - goto L140; -L120: - sh11 = sparam[2]; - sh12 = sparam[4]; - sh21 = sparam[3]; - sh22 = sparam[5]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = sx[kx]; - z__ = sy[ky]; - sx[kx] = w * sh11 + z__ * sh12; - sy[ky] = w * sh21 + z__ * sh22; - kx += *incx; - ky += *incy; -/* L130: */ - } -L140: - return 0; -} /* srotm_ */ - diff --git a/eigen/blas/f2c/srotmg.c b/eigen/blas/f2c/srotmg.c deleted file mode 100644 index 75f789f..0000000 --- a/eigen/blas/f2c/srotmg.c +++ /dev/null @@ -1,295 +0,0 @@ -/* srotmg.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real - *sparam) -{ - /* Initialized data */ - - static real zero = 0.f; - static real one = 1.f; - static real two = 2.f; - static real gam = 4096.f; - static real gamsq = 16777200.f; - static real rgamsq = 5.96046e-8f; - - /* Format strings */ - static char fmt_120[] = ""; - static char fmt_150[] = ""; - static char fmt_180[] = ""; - static char fmt_210[] = ""; - - /* System generated locals */ - real r__1; - - /* Local variables */ - real su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22; - integer igo; - real sflag, stemp; - - /* Assigned format variables */ - static char *igo_fmt; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ -/* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */ -/* SY2)**T. */ -/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ - -/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ - -/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ -/* H=( ) ( ) ( ) ( ) */ -/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ -/* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */ -/* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */ -/* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */ - -/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ -/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ -/* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ - - -/* Arguments */ -/* ========= */ - - -/* SD1 (input/output) REAL */ - -/* SD2 (input/output) REAL */ - -/* SX1 (input/output) REAL */ - -/* SY1 (input) REAL */ - - -/* SPARAM (input/output) REAL array, dimension 5 */ -/* SPARAM(1)=SFLAG */ -/* SPARAM(2)=SH11 */ -/* SPARAM(3)=SH21 */ -/* SPARAM(4)=SH12 */ -/* SPARAM(5)=SH22 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Data statements .. */ - - /* Parameter adjustments */ - --sparam; - - /* Function Body */ -/* .. */ - if (! (*sd1 < zero)) { - goto L10; - } -/* GO ZERO-H-D-AND-SX1.. */ - goto L60; -L10: -/* CASE-SD1-NONNEGATIVE */ - sp2 = *sd2 * *sy1; - if (! (sp2 == zero)) { - goto L20; - } - sflag = -two; - goto L260; -/* REGULAR-CASE.. */ -L20: - sp1 = *sd1 * *sx1; - sq2 = sp2 * *sy1; - sq1 = sp1 * *sx1; - - if (! (dabs(sq1) > dabs(sq2))) { - goto L40; - } - sh21 = -(*sy1) / *sx1; - sh12 = sp2 / sp1; - - su = one - sh12 * sh21; - - if (! (su <= zero)) { - goto L30; - } -/* GO ZERO-H-D-AND-SX1.. */ - goto L60; -L30: - sflag = zero; - *sd1 /= su; - *sd2 /= su; - *sx1 *= su; -/* GO SCALE-CHECK.. */ - goto L100; -L40: - if (! (sq2 < zero)) { - goto L50; - } -/* GO ZERO-H-D-AND-SX1.. */ - goto L60; -L50: - sflag = one; - sh11 = sp1 / sp2; - sh22 = *sx1 / *sy1; - su = one + sh11 * sh22; - stemp = *sd2 / su; - *sd2 = *sd1 / su; - *sd1 = stemp; - *sx1 = *sy1 * su; -/* GO SCALE-CHECK */ - goto L100; -/* PROCEDURE..ZERO-H-D-AND-SX1.. */ -L60: - sflag = -one; - sh11 = zero; - sh12 = zero; - sh21 = zero; - sh22 = zero; - - *sd1 = zero; - *sd2 = zero; - *sx1 = zero; -/* RETURN.. */ - goto L220; -/* PROCEDURE..FIX-H.. */ -L70: - if (! (sflag >= zero)) { - goto L90; - } - - if (! (sflag == zero)) { - goto L80; - } - sh11 = one; - sh22 = one; - sflag = -one; - goto L90; -L80: - sh21 = -one; - sh12 = one; - sflag = -one; -L90: - switch (igo) { - case 0: goto L120; - case 1: goto L150; - case 2: goto L180; - case 3: goto L210; - } -/* PROCEDURE..SCALE-CHECK */ -L100: -L110: - if (! (*sd1 <= rgamsq)) { - goto L130; - } - if (*sd1 == zero) { - goto L160; - } - igo = 0; - igo_fmt = fmt_120; -/* FIX-H.. */ - goto L70; -L120: -/* Computing 2nd power */ - r__1 = gam; - *sd1 *= r__1 * r__1; - *sx1 /= gam; - sh11 /= gam; - sh12 /= gam; - goto L110; -L130: -L140: - if (! (*sd1 >= gamsq)) { - goto L160; - } - igo = 1; - igo_fmt = fmt_150; -/* FIX-H.. */ - goto L70; -L150: -/* Computing 2nd power */ - r__1 = gam; - *sd1 /= r__1 * r__1; - *sx1 *= gam; - sh11 *= gam; - sh12 *= gam; - goto L140; -L160: -L170: - if (! (dabs(*sd2) <= rgamsq)) { - goto L190; - } - if (*sd2 == zero) { - goto L220; - } - igo = 2; - igo_fmt = fmt_180; -/* FIX-H.. */ - goto L70; -L180: -/* Computing 2nd power */ - r__1 = gam; - *sd2 *= r__1 * r__1; - sh21 /= gam; - sh22 /= gam; - goto L170; -L190: -L200: - if (! (dabs(*sd2) >= gamsq)) { - goto L220; - } - igo = 3; - igo_fmt = fmt_210; -/* FIX-H.. */ - goto L70; -L210: -/* Computing 2nd power */ - r__1 = gam; - *sd2 /= r__1 * r__1; - sh21 *= gam; - sh22 *= gam; - goto L200; -L220: - if (sflag < 0.f) { - goto L250; - } else if (sflag == 0) { - goto L230; - } else { - goto L240; - } -L230: - sparam[3] = sh21; - sparam[4] = sh12; - goto L260; -L240: - sparam[2] = sh11; - sparam[5] = sh22; - goto L260; -L250: - sparam[2] = sh11; - sparam[3] = sh21; - sparam[4] = sh12; - sparam[5] = sh22; -L260: - sparam[1] = sflag; - return 0; -} /* srotmg_ */ - diff --git a/eigen/blas/f2c/ssbmv.c b/eigen/blas/f2c/ssbmv.c deleted file mode 100644 index 8599325..0000000 --- a/eigen/blas/f2c/ssbmv.c +++ /dev/null @@ -1,368 +0,0 @@ -/* ssbmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha, - real *a, integer *lda, real *x, integer *incx, real *beta, real *y, - integer *incy, ftnlen uplo_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ix, iy, jx, jy, kx, ky, info; - real temp1, temp2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer kplus1; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSBMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric band matrix, with k super-diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the band matrix A is being supplied as */ -/* follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* being supplied. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* being supplied. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry, K specifies the number of super-diagonals of the */ -/* matrix A. K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the symmetric matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer the upper */ -/* triangular part of a symmetric band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the symmetric matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer the lower */ -/* triangular part of a symmetric band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. LDA must be at least */ -/* ( k + 1 ). */ -/* Unchanged on exit. */ - -/* X - REAL array of DIMENSION at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the */ -/* vector x. */ -/* Unchanged on exit. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* BETA - REAL . */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* Y - REAL array of DIMENSION at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the */ -/* vector y. On exit, Y is overwritten by the updated vector y. */ - -/* INCY - INTEGER. */ -/* On entry, INCY specifies the increment for the elements of */ -/* Y. INCY must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*k < 0) { - info = 3; - } else if (*lda < *k + 1) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("SSBMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array A */ -/* are accessed sequentially with one pass through A. */ - -/* First form y := beta*y. */ - - if (*beta != 1.f) { - if (*incy == 1) { - if (*beta == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.f; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.f; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.f) { - return 0; - } - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - -/* Form y when upper triangle of A is stored. */ - - kplus1 = *k + 1; - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.f; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - y[i__] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[i__]; -/* L50: */ - } - y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.f; - ix = kx; - iy = ky; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - y[iy] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * - temp2; - jx += *incx; - jy += *incy; - if (j > *k) { - kx += *incx; - ky += *incy; - } -/* L80: */ - } - } - } else { - -/* Form y when lower triangle of A is stored. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.f; - y[j] += temp1 * a[j * a_dim1 + 1]; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - y[i__] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[j] += *alpha * temp2; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.f; - y[jy] += temp1 * a[j * a_dim1 + 1]; - l = 1 - j; - ix = jx; - iy = jy; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of SSBMV . */ - -} /* ssbmv_ */ - diff --git a/eigen/blas/f2c/sspmv.c b/eigen/blas/f2c/sspmv.c deleted file mode 100644 index 47858ec..0000000 --- a/eigen/blas/f2c/sspmv.c +++ /dev/null @@ -1,316 +0,0 @@ -/* sspmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap, - real *x, integer *incx, real *beta, real *y, integer *incy, ftnlen - uplo_len) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; - real temp1, temp2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSPMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric matrix, supplied in packed form. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the matrix A is supplied in the packed */ -/* array AP as follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* supplied in AP. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* supplied in AP. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* AP - REAL array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ -/* and a( 2, 2 ) respectively, and so on. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ -/* and a( 3, 1 ) respectively, and so on. */ -/* Unchanged on exit. */ - -/* X - REAL array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. */ -/* Unchanged on exit. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* BETA - REAL . */ -/* On entry, BETA specifies the scalar beta. When BETA is */ -/* supplied as zero then Y need not be set on input. */ -/* Unchanged on exit. */ - -/* Y - REAL array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the n */ -/* element vector y. On exit, Y is overwritten by the updated */ -/* vector y. */ - -/* INCY - INTEGER. */ -/* On entry, INCY specifies the increment for the elements of */ -/* Y. INCY must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --y; - --x; - --ap; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 6; - } else if (*incy == 0) { - info = 9; - } - if (info != 0) { - xerbla_("SSPMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array AP */ -/* are accessed sequentially with one pass through AP. */ - -/* First form y := beta*y. */ - - if (*beta != 1.f) { - if (*incy == 1) { - if (*beta == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.f; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.f; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.f) { - return 0; - } - kk = 1; - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - -/* Form y when AP contains the upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.f; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * ap[k]; - temp2 += ap[k] * x[i__]; - ++k; -/* L50: */ - } - y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; - kk += j; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.f; - ix = kx; - iy = ky; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - y[iy] += temp1 * ap[k]; - temp2 += ap[k] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; - jx += *incx; - jy += *incy; - kk += j; -/* L80: */ - } - } - } else { - -/* Form y when AP contains the lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.f; - y[j] += temp1 * ap[kk]; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * ap[k]; - temp2 += ap[k] * x[i__]; - ++k; -/* L90: */ - } - y[j] += *alpha * temp2; - kk += *n - j + 1; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.f; - y[jy] += temp1 * ap[kk]; - ix = jx; - iy = jy; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * ap[k]; - temp2 += ap[k] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; - kk += *n - j + 1; -/* L120: */ - } - } - } - - return 0; - -/* End of SSPMV . */ - -} /* sspmv_ */ - diff --git a/eigen/blas/f2c/stbmv.c b/eigen/blas/f2c/stbmv.c deleted file mode 100644 index fcf9ce3..0000000 --- a/eigen/blas/f2c/stbmv.c +++ /dev/null @@ -1,428 +0,0 @@ -/* stbmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, real *a, integer *lda, real *x, integer *incx, ftnlen - uplo_len, ftnlen trans_len, ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ix, jx, kx, info; - real temp; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer kplus1; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - logical nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* STBMV performs one of the matrix-vector operations */ - -/* x := A*x, or x := A'*x, */ - -/* where x is an n element vector and A is an n by n unit, or non-unit, */ -/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' x := A*x. */ - -/* TRANS = 'T' or 't' x := A'*x. */ - -/* TRANS = 'C' or 'c' x := A'*x. */ - -/* Unchanged on exit. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit */ -/* triangular as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with UPLO = 'U' or 'u', K specifies the number of */ -/* super-diagonals of the matrix A. */ -/* On entry with UPLO = 'L' or 'l', K specifies the number of */ -/* sub-diagonals of the matrix A. */ -/* K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer an upper */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer a lower */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Note that when DIAG = 'U' or 'u' the elements of the array A */ -/* corresponding to the diagonal elements of the matrix are not */ -/* referenced, but are assumed to be unity. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. LDA must be at least */ -/* ( k + 1 ). */ -/* Unchanged on exit. */ - -/* X - REAL array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. On exit, X is overwritten with the */ -/* tranformed vector x. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - "N", (ftnlen)1, (ftnlen)1)) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < *k + 1) { - info = 7; - } else if (*incx == 0) { - info = 9; - } - if (info != 0) { - xerbla_("STBMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); - -/* Set up the start point in X if the increment is not unity. This */ -/* will be ( N - 1 )*INCX too small for descending loops. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) { - -/* Form x := A*x. */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - kplus1 = *k + 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.f) { - temp = x[j]; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - x[i__] += temp * a[l + i__ + j * a_dim1]; -/* L10: */ - } - if (nounit) { - x[j] *= a[kplus1 + j * a_dim1]; - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.f) { - temp = x[jx]; - ix = kx; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - x[ix] += temp * a[l + i__ + j * a_dim1]; - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= a[kplus1 + j * a_dim1]; - } - } - jx += *incx; - if (j > *k) { - kx += *incx; - } -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.f) { - temp = x[j]; - l = 1 - j; -/* Computing MIN */ - i__1 = *n, i__3 = j + *k; - i__4 = j + 1; - for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { - x[i__] += temp * a[l + i__ + j * a_dim1]; -/* L50: */ - } - if (nounit) { - x[j] *= a[j * a_dim1 + 1]; - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.f) { - temp = x[jx]; - ix = kx; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__1 = j + *k; - i__3 = j + 1; - for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { - x[ix] += temp * a[l + i__ + j * a_dim1]; - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= a[j * a_dim1 + 1]; - } - } - jx -= *incx; - if (*n - j >= *k) { - kx -= *incx; - } -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x. */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - kplus1 = *k + 1; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - l = kplus1 - j; - if (nounit) { - temp *= a[kplus1 + j * a_dim1]; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - temp += a[l + i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - x[j] = temp; -/* L100: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - kx -= *incx; - ix = kx; - l = kplus1 - j; - if (nounit) { - temp *= a[kplus1 + j * a_dim1]; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - temp += a[l + i__ + j * a_dim1] * x[ix]; - ix -= *incx; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - temp = x[j]; - l = 1 - j; - if (nounit) { - temp *= a[j * a_dim1 + 1]; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - temp += a[l + i__ + j * a_dim1] * x[i__]; -/* L130: */ - } - x[j] = temp; -/* L140: */ - } - } else { - jx = kx; - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - temp = x[jx]; - kx += *incx; - ix = kx; - l = 1 - j; - if (nounit) { - temp *= a[j * a_dim1 + 1]; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - temp += a[l + i__ + j * a_dim1] * x[ix]; - ix += *incx; -/* L150: */ - } - x[jx] = temp; - jx += *incx; -/* L160: */ - } - } - } - } - - return 0; - -/* End of STBMV . */ - -} /* stbmv_ */ - diff --git a/eigen/blas/f2c/zhbmv.c b/eigen/blas/f2c/zhbmv.c deleted file mode 100644 index 42da13d..0000000 --- a/eigen/blas/f2c/zhbmv.c +++ /dev/null @@ -1,488 +0,0 @@ -/* zhbmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int zhbmv_(char *uplo, integer *n, integer *k, doublecomplex - *alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer * - incx, doublecomplex *beta, doublecomplex *y, integer *incy, ftnlen - uplo_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - doublereal d__1; - doublecomplex z__1, z__2, z__3, z__4; - - /* Builtin functions */ - void d_cnjg(doublecomplex *, doublecomplex *); - - /* Local variables */ - integer i__, j, l, ix, iy, jx, jy, kx, ky, info; - doublecomplex temp1, temp2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer kplus1; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* ZHBMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n hermitian band matrix, with k super-diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the band matrix A is being supplied as */ -/* follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* being supplied. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* being supplied. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry, K specifies the number of super-diagonals of the */ -/* matrix A. K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* ALPHA - COMPLEX*16 . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the hermitian matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer the upper */ -/* triangular part of a hermitian band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the hermitian matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer the lower */ -/* triangular part of a hermitian band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Note that the imaginary parts of the diagonal elements need */ -/* not be set and are assumed to be zero. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. LDA must be at least */ -/* ( k + 1 ). */ -/* Unchanged on exit. */ - -/* X - COMPLEX*16 array of DIMENSION at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the */ -/* vector x. */ -/* Unchanged on exit. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* BETA - COMPLEX*16 . */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* Y - COMPLEX*16 array of DIMENSION at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the */ -/* vector y. On exit, Y is overwritten by the updated vector y. */ - -/* INCY - INTEGER. */ -/* On entry, INCY specifies the increment for the elements of */ -/* Y. INCY must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*k < 0) { - info = 3; - } else if (*lda < *k + 1) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("ZHBMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && - beta->i == 0.))) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array A */ -/* are accessed sequentially with one pass through A. */ - -/* First form y := beta*y. */ - - if (beta->r != 1. || beta->i != 0.) { - if (*incy == 1) { - if (beta->r == 0. && beta->i == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - y[i__2].r = 0., y[i__2].i = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; -/* L20: */ - } - } - } else { - iy = ky; - if (beta->r == 0. && beta->i == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - y[i__2].r = 0., y[i__2].i = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - i__3 = iy; - z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - iy += *incy; -/* L40: */ - } - } - } - } - if (alpha->r == 0. && alpha->i == 0.) { - return 0; - } - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - -/* Form y when upper triangle of A is stored. */ - - kplus1 = *k + 1; - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - i__2 = i__; - i__3 = i__; - i__5 = l + i__ + j * a_dim1; - z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); - i__2 = i__; - z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, z__2.i = - z__3.r * x[i__2].i + z__3.i * x[i__2].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; -/* L50: */ - } - i__4 = j; - i__2 = j; - i__3 = kplus1 + j * a_dim1; - d__1 = a[i__3].r; - z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; - z__2.r = y[i__2].r + z__3.r, z__2.i = y[i__2].i + z__3.i; - z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - y[i__4].r = z__1.r, y[i__4].i = z__1.i; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__4 = jx; - z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i = - alpha->r * x[i__4].i + alpha->i * x[i__4].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - ix = kx; - iy = ky; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - i__4 = iy; - i__2 = iy; - i__5 = l + i__ + j * a_dim1; - z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i; - y[i__4].r = z__1.r, y[i__4].i = z__1.i; - d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); - i__4 = ix; - z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = - z__3.r * x[i__4].i + z__3.i * x[i__4].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; - ix += *incx; - iy += *incy; -/* L70: */ - } - i__3 = jy; - i__4 = jy; - i__2 = kplus1 + j * a_dim1; - d__1 = a[i__2].r; - z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; - z__2.r = y[i__4].r + z__3.r, z__2.i = y[i__4].i + z__3.i; - z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - jx += *incx; - jy += *incy; - if (j > *k) { - kx += *incx; - ky += *incy; - } -/* L80: */ - } - } - } else { - -/* Form y when lower triangle of A is stored. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__3 = j; - z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i = - alpha->r * x[i__3].i + alpha->i * x[i__3].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - i__3 = j; - i__4 = j; - i__2 = j * a_dim1 + 1; - d__1 = a[i__2].r; - z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__2 = i__; - i__5 = l + i__ + j * a_dim1; - z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i; - y[i__4].r = z__1.r, y[i__4].i = z__1.i; - d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); - i__4 = i__; - z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = - z__3.r * x[i__4].i + z__3.i * x[i__4].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; -/* L90: */ - } - i__3 = j; - i__4 = j; - z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__3 = jx; - z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i = - alpha->r * x[i__3].i + alpha->i * x[i__3].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - i__3 = jy; - i__4 = jy; - i__2 = j * a_dim1 + 1; - d__1 = a[i__2].r; - z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - l = 1 - j; - ix = jx; - iy = jy; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - ix += *incx; - iy += *incy; - i__4 = iy; - i__2 = iy; - i__5 = l + i__ + j * a_dim1; - z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, - z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] - .r; - z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i; - y[i__4].r = z__1.r, y[i__4].i = z__1.i; - d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); - i__4 = ix; - z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = - z__3.r * x[i__4].i + z__3.i * x[i__4].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; -/* L110: */ - } - i__3 = jy; - i__4 = jy; - z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of ZHBMV . */ - -} /* zhbmv_ */ - diff --git a/eigen/blas/f2c/zhpmv.c b/eigen/blas/f2c/zhpmv.c deleted file mode 100644 index fbe2f42..0000000 --- a/eigen/blas/f2c/zhpmv.c +++ /dev/null @@ -1,438 +0,0 @@ -/* zhpmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int zhpmv_(char *uplo, integer *n, doublecomplex *alpha, - doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex * - beta, doublecomplex *y, integer *incy, ftnlen uplo_len) -{ - /* System generated locals */ - integer i__1, i__2, i__3, i__4, i__5; - doublereal d__1; - doublecomplex z__1, z__2, z__3, z__4; - - /* Builtin functions */ - void d_cnjg(doublecomplex *, doublecomplex *); - - /* Local variables */ - integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; - doublecomplex temp1, temp2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* ZHPMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n hermitian matrix, supplied in packed form. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the matrix A is supplied in the packed */ -/* array AP as follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* supplied in AP. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* supplied in AP. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - COMPLEX*16 . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* AP - COMPLEX*16 array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular part of the hermitian matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ -/* and a( 2, 2 ) respectively, and so on. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular part of the hermitian matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ -/* and a( 3, 1 ) respectively, and so on. */ -/* Note that the imaginary parts of the diagonal elements need */ -/* not be set and are assumed to be zero. */ -/* Unchanged on exit. */ - -/* X - COMPLEX*16 array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. */ -/* Unchanged on exit. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* BETA - COMPLEX*16 . */ -/* On entry, BETA specifies the scalar beta. When BETA is */ -/* supplied as zero then Y need not be set on input. */ -/* Unchanged on exit. */ - -/* Y - COMPLEX*16 array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the n */ -/* element vector y. On exit, Y is overwritten by the updated */ -/* vector y. */ - -/* INCY - INTEGER. */ -/* On entry, INCY specifies the increment for the elements of */ -/* Y. INCY must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --y; - --x; - --ap; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 6; - } else if (*incy == 0) { - info = 9; - } - if (info != 0) { - xerbla_("ZHPMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && - beta->i == 0.))) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array AP */ -/* are accessed sequentially with one pass through AP. */ - -/* First form y := beta*y. */ - - if (beta->r != 1. || beta->i != 0.) { - if (*incy == 1) { - if (beta->r == 0. && beta->i == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - y[i__2].r = 0., y[i__2].i = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; -/* L20: */ - } - } - } else { - iy = ky; - if (beta->r == 0. && beta->i == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - y[i__2].r = 0., y[i__2].i = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = iy; - i__3 = iy; - z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, - z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] - .r; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - iy += *incy; -/* L40: */ - } - } - } - } - if (alpha->r == 0. && alpha->i == 0.) { - return 0; - } - kk = 1; - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - -/* Form y when AP contains the upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = k; - z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, - z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] - .r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - d_cnjg(&z__3, &ap[k]); - i__3 = i__; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = - z__3.r * x[i__3].i + z__3.i * x[i__3].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; - ++k; -/* L50: */ - } - i__2 = j; - i__3 = j; - i__4 = kk + j - 1; - d__1 = ap[i__4].r; - z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; - z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; - z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - kk += j; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - ix = kx; - iy = ky; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - i__3 = iy; - i__4 = iy; - i__5 = k; - z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, - z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] - .r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - d_cnjg(&z__3, &ap[k]); - i__3 = ix; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = - z__3.r * x[i__3].i + z__3.i * x[i__3].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; - ix += *incx; - iy += *incy; -/* L70: */ - } - i__2 = jy; - i__3 = jy; - i__4 = kk + j - 1; - d__1 = ap[i__4].r; - z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; - z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; - z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - jx += *incx; - jy += *incy; - kk += j; -/* L80: */ - } - } - } else { - -/* Form y when AP contains the lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - i__2 = j; - i__3 = j; - i__4 = kk; - d__1 = ap[i__4].r; - z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - i__5 = k; - z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, - z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] - .r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - d_cnjg(&z__3, &ap[k]); - i__3 = i__; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = - z__3.r * x[i__3].i + z__3.i * x[i__3].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; - ++k; -/* L90: */ - } - i__2 = j; - i__3 = j; - z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - kk += *n - j + 1; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = jx; - z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = - alpha->r * x[i__2].i + alpha->i * x[i__2].r; - temp1.r = z__1.r, temp1.i = z__1.i; - temp2.r = 0., temp2.i = 0.; - i__2 = jy; - i__3 = jy; - i__4 = kk; - d__1 = ap[i__4].r; - z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - ix = jx; - iy = jy; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - iy += *incy; - i__3 = iy; - i__4 = iy; - i__5 = k; - z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, - z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] - .r; - z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; - y[i__3].r = z__1.r, y[i__3].i = z__1.i; - d_cnjg(&z__3, &ap[k]); - i__3 = ix; - z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = - z__3.r * x[i__3].i + z__3.i * x[i__3].r; - z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; - temp2.r = z__1.r, temp2.i = z__1.i; -/* L110: */ - } - i__2 = jy; - i__3 = jy; - z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = - alpha->r * temp2.i + alpha->i * temp2.r; - z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; - y[i__2].r = z__1.r, y[i__2].i = z__1.i; - jx += *incx; - jy += *incy; - kk += *n - j + 1; -/* L120: */ - } - } - } - - return 0; - -/* End of ZHPMV . */ - -} /* zhpmv_ */ - diff --git a/eigen/blas/f2c/ztbmv.c b/eigen/blas/f2c/ztbmv.c deleted file mode 100644 index 4cdcd7f..0000000 --- a/eigen/blas/f2c/ztbmv.c +++ /dev/null @@ -1,647 +0,0 @@ -/* ztbmv.f -- translated by f2c (version 20100827). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "datatypes.h" - -/* Subroutine */ int ztbmv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer - *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - doublecomplex z__1, z__2, z__3; - - /* Builtin functions */ - void d_cnjg(doublecomplex *, doublecomplex *); - - /* Local variables */ - integer i__, j, l, ix, jx, kx, info; - doublecomplex temp; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - integer kplus1; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - logical noconj, nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* ZTBMV performs one of the matrix-vector operations */ - -/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ - -/* where x is an n element vector and A is an n by n unit, or non-unit, */ -/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' x := A*x. */ - -/* TRANS = 'T' or 't' x := A'*x. */ - -/* TRANS = 'C' or 'c' x := conjg( A' )*x. */ - -/* Unchanged on exit. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit */ -/* triangular as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with UPLO = 'U' or 'u', K specifies the number of */ -/* super-diagonals of the matrix A. */ -/* On entry with UPLO = 'L' or 'l', K specifies the number of */ -/* sub-diagonals of the matrix A. */ -/* K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer an upper */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer a lower */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Note that when DIAG = 'U' or 'u' the elements of the array A */ -/* corresponding to the diagonal elements of the matrix are not */ -/* referenced, but are assumed to be unity. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. LDA must be at least */ -/* ( k + 1 ). */ -/* Unchanged on exit. */ - -/* X - COMPLEX*16 array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. On exit, X is overwritten with the */ -/* tranformed vector x. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX must not be zero. */ -/* Unchanged on exit. */ - -/* Further Details */ -/* =============== */ - -/* Level 2 Blas routine. */ - -/* -- Written on 22-October-1986. */ -/* Jack Dongarra, Argonne National Lab. */ -/* Jeremy Du Croz, Nag Central Office. */ -/* Sven Hammarling, Nag Central Office. */ -/* Richard Hanson, Sandia National Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - info = 1; - } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( - ftnlen)1)) { - info = 2; - } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag, - "N", (ftnlen)1, (ftnlen)1)) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < *k + 1) { - info = 7; - } else if (*incx == 0) { - info = 9; - } - if (info != 0) { - xerbla_("ZTBMV ", &info, (ftnlen)6); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1); - nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); - -/* Set up the start point in X if the increment is not unity. This */ -/* will be ( N - 1 )*INCX too small for descending loops. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) { - -/* Form x := A*x. */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - kplus1 = *k + 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - if (x[i__2].r != 0. || x[i__2].i != 0.) { - i__2 = j; - temp.r = x[i__2].r, temp.i = x[i__2].i; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - i__2 = i__; - i__3 = i__; - i__5 = l + i__ + j * a_dim1; - z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, - z__2.i = temp.r * a[i__5].i + temp.i * a[ - i__5].r; - z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + - z__2.i; - x[i__2].r = z__1.r, x[i__2].i = z__1.i; -/* L10: */ - } - if (nounit) { - i__4 = j; - i__2 = j; - i__3 = kplus1 + j * a_dim1; - z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ - i__3].i, z__1.i = x[i__2].r * a[i__3].i + - x[i__2].i * a[i__3].r; - x[i__4].r = z__1.r, x[i__4].i = z__1.i; - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__4 = jx; - if (x[i__4].r != 0. || x[i__4].i != 0.) { - i__4 = jx; - temp.r = x[i__4].r, temp.i = x[i__4].i; - ix = kx; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - i__4 = ix; - i__2 = ix; - i__5 = l + i__ + j * a_dim1; - z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, - z__2.i = temp.r * a[i__5].i + temp.i * a[ - i__5].r; - z__1.r = x[i__2].r + z__2.r, z__1.i = x[i__2].i + - z__2.i; - x[i__4].r = z__1.r, x[i__4].i = z__1.i; - ix += *incx; -/* L30: */ - } - if (nounit) { - i__3 = jx; - i__4 = jx; - i__2 = kplus1 + j * a_dim1; - z__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[ - i__2].i, z__1.i = x[i__4].r * a[i__2].i + - x[i__4].i * a[i__2].r; - x[i__3].r = z__1.r, x[i__3].i = z__1.i; - } - } - jx += *incx; - if (j > *k) { - kx += *incx; - } -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__1 = j; - if (x[i__1].r != 0. || x[i__1].i != 0.) { - i__1 = j; - temp.r = x[i__1].r, temp.i = x[i__1].i; - l = 1 - j; -/* Computing MIN */ - i__1 = *n, i__3 = j + *k; - i__4 = j + 1; - for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { - i__1 = i__; - i__3 = i__; - i__2 = l + i__ + j * a_dim1; - z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, - z__2.i = temp.r * a[i__2].i + temp.i * a[ - i__2].r; - z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + - z__2.i; - x[i__1].r = z__1.r, x[i__1].i = z__1.i; -/* L50: */ - } - if (nounit) { - i__4 = j; - i__1 = j; - i__3 = j * a_dim1 + 1; - z__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[ - i__3].i, z__1.i = x[i__1].r * a[i__3].i + - x[i__1].i * a[i__3].r; - x[i__4].r = z__1.r, x[i__4].i = z__1.i; - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - i__4 = jx; - if (x[i__4].r != 0. || x[i__4].i != 0.) { - i__4 = jx; - temp.r = x[i__4].r, temp.i = x[i__4].i; - ix = kx; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__1 = j + *k; - i__3 = j + 1; - for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { - i__4 = ix; - i__1 = ix; - i__2 = l + i__ + j * a_dim1; - z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, - z__2.i = temp.r * a[i__2].i + temp.i * a[ - i__2].r; - z__1.r = x[i__1].r + z__2.r, z__1.i = x[i__1].i + - z__2.i; - x[i__4].r = z__1.r, x[i__4].i = z__1.i; - ix -= *incx; -/* L70: */ - } - if (nounit) { - i__3 = jx; - i__4 = jx; - i__1 = j * a_dim1 + 1; - z__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[ - i__1].i, z__1.i = x[i__4].r * a[i__1].i + - x[i__4].i * a[i__1].r; - x[i__3].r = z__1.r, x[i__3].i = z__1.i; - } - } - jx -= *incx; - if (*n - j >= *k) { - kx -= *incx; - } -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x or x := conjg( A' )*x. */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - kplus1 = *k + 1; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - i__3 = j; - temp.r = x[i__3].r, temp.i = x[i__3].i; - l = kplus1 - j; - if (noconj) { - if (nounit) { - i__3 = kplus1 + j * a_dim1; - z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, - z__1.i = temp.r * a[i__3].i + temp.i * a[ - i__3].r; - temp.r = z__1.r, temp.i = z__1.i; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - i__4 = l + i__ + j * a_dim1; - i__1 = i__; - z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ - i__1].i, z__2.i = a[i__4].r * x[i__1].i + - a[i__4].i * x[i__1].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; -/* L90: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[kplus1 + j * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); - i__4 = i__; - z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, - z__2.i = z__3.r * x[i__4].i + z__3.i * x[ - i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; -/* L100: */ - } - } - i__3 = j; - x[i__3].r = temp.r, x[i__3].i = temp.i; -/* L110: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - i__3 = jx; - temp.r = x[i__3].r, temp.i = x[i__3].i; - kx -= *incx; - ix = kx; - l = kplus1 - j; - if (noconj) { - if (nounit) { - i__3 = kplus1 + j * a_dim1; - z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, - z__1.i = temp.r * a[i__3].i + temp.i * a[ - i__3].r; - temp.r = z__1.r, temp.i = z__1.i; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - i__4 = l + i__ + j * a_dim1; - i__1 = ix; - z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ - i__1].i, z__2.i = a[i__4].r * x[i__1].i + - a[i__4].i * x[i__1].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix -= *incx; -/* L120: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[kplus1 + j * a_dim1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); - i__4 = ix; - z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, - z__2.i = z__3.r * x[i__4].i + z__3.i * x[ - i__4].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix -= *incx; -/* L130: */ - } - } - i__3 = jx; - x[i__3].r = temp.r, x[i__3].i = temp.i; - jx -= *incx; -/* L140: */ - } - } - } else { - if (*incx == 1) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - i__4 = j; - temp.r = x[i__4].r, temp.i = x[i__4].i; - l = 1 - j; - if (noconj) { - if (nounit) { - i__4 = j * a_dim1 + 1; - z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, - z__1.i = temp.r * a[i__4].i + temp.i * a[ - i__4].r; - temp.r = z__1.r, temp.i = z__1.i; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - i__1 = l + i__ + j * a_dim1; - i__2 = i__; - z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ - i__2].i, z__2.i = a[i__1].r * x[i__2].i + - a[i__1].i * x[i__2].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; -/* L150: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[j * a_dim1 + 1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); - i__1 = i__; - z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, - z__2.i = z__3.r * x[i__1].i + z__3.i * x[ - i__1].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; -/* L160: */ - } - } - i__4 = j; - x[i__4].r = temp.r, x[i__4].i = temp.i; -/* L170: */ - } - } else { - jx = kx; - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - i__4 = jx; - temp.r = x[i__4].r, temp.i = x[i__4].i; - kx += *incx; - ix = kx; - l = 1 - j; - if (noconj) { - if (nounit) { - i__4 = j * a_dim1 + 1; - z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, - z__1.i = temp.r * a[i__4].i + temp.i * a[ - i__4].r; - temp.r = z__1.r, temp.i = z__1.i; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - i__1 = l + i__ + j * a_dim1; - i__2 = ix; - z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ - i__2].i, z__2.i = a[i__1].r * x[i__2].i + - a[i__1].i * x[i__2].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix += *incx; -/* L180: */ - } - } else { - if (nounit) { - d_cnjg(&z__2, &a[j * a_dim1 + 1]); - z__1.r = temp.r * z__2.r - temp.i * z__2.i, - z__1.i = temp.r * z__2.i + temp.i * - z__2.r; - temp.r = z__1.r, temp.i = z__1.i; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); - i__1 = ix; - z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, - z__2.i = z__3.r * x[i__1].i + z__3.i * x[ - i__1].r; - z__1.r = temp.r + z__2.r, z__1.i = temp.i + - z__2.i; - temp.r = z__1.r, temp.i = z__1.i; - ix += *incx; -/* L190: */ - } - } - i__4 = jx; - x[i__4].r = temp.r, x[i__4].i = temp.i; - jx += *incx; -/* L200: */ - } - } - } - } - - return 0; - -/* End of ZTBMV . */ - -} /* ztbmv_ */ - diff --git a/eigen/blas/fortran/complexdots.f b/eigen/blas/fortran/complexdots.f deleted file mode 100644 index a7da51d..0000000 --- a/eigen/blas/fortran/complexdots.f +++ /dev/null @@ -1,43 +0,0 @@ - COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) - INTEGER INCX,INCY,N - COMPLEX CX(*),CY(*) - COMPLEX RES - EXTERNAL CDOTCW - - CALL CDOTCW(N,CX,INCX,CY,INCY,RES) - CDOTC = RES - RETURN - END - - COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) - INTEGER INCX,INCY,N - COMPLEX CX(*),CY(*) - COMPLEX RES - EXTERNAL CDOTUW - - CALL CDOTUW(N,CX,INCX,CY,INCY,RES) - CDOTU = RES - RETURN - END - - DOUBLE COMPLEX FUNCTION ZDOTC(N,CX,INCX,CY,INCY) - INTEGER INCX,INCY,N - DOUBLE COMPLEX CX(*),CY(*) - DOUBLE COMPLEX RES - EXTERNAL ZDOTCW - - CALL ZDOTCW(N,CX,INCX,CY,INCY,RES) - ZDOTC = RES - RETURN - END - - DOUBLE COMPLEX FUNCTION ZDOTU(N,CX,INCX,CY,INCY) - INTEGER INCX,INCY,N - DOUBLE COMPLEX CX(*),CY(*) - DOUBLE COMPLEX RES - EXTERNAL ZDOTUW - - CALL ZDOTUW(N,CX,INCX,CY,INCY,RES) - ZDOTU = RES - RETURN - END diff --git a/eigen/blas/level1_cplx_impl.h b/eigen/blas/level1_cplx_impl.h deleted file mode 100644 index 719f5ba..0000000 --- a/eigen/blas/level1_cplx_impl.h +++ /dev/null @@ -1,133 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009-2010 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#include "common.h" - -struct scalar_norm1_op { - typedef RealScalar result_type; - EIGEN_EMPTY_STRUCT_CTOR(scalar_norm1_op) - inline RealScalar operator() (const Scalar& a) const { return numext::norm1(a); } -}; -namespace Eigen { - namespace internal { - template<> struct functor_traits<scalar_norm1_op > - { - enum { Cost = 3 * NumTraits<Scalar>::AddCost, PacketAccess = 0 }; - }; - } -} - -// computes the sum of magnitudes of all vector elements or, for a complex vector x, the sum -// res = |Rex1| + |Imx1| + |Rex2| + |Imx2| + ... + |Rexn| + |Imxn|, where x is a vector of order n -RealScalar EIGEN_CAT(EIGEN_CAT(REAL_SCALAR_SUFFIX,SCALAR_SUFFIX),asum_)(int *n, RealScalar *px, int *incx) -{ -// std::cerr << "__asum " << *n << " " << *incx << "\n"; - Complex* x = reinterpret_cast<Complex*>(px); - - if(*n<=0) return 0; - - if(*incx==1) return make_vector(x,*n).unaryExpr<scalar_norm1_op>().sum(); - else return make_vector(x,*n,std::abs(*incx)).unaryExpr<scalar_norm1_op>().sum(); -} - -// computes a dot product of a conjugated vector with another vector. -int EIGEN_BLAS_FUNC(dotcw)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar* pres) -{ -// std::cerr << "_dotc " << *n << " " << *incx << " " << *incy << "\n"; - Scalar* res = reinterpret_cast<Scalar*>(pres); - - if(*n<=0) - { - *res = Scalar(0); - return 0; - } - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - - if(*incx==1 && *incy==1) *res = (make_vector(x,*n).dot(make_vector(y,*n))); - else if(*incx>0 && *incy>0) *res = (make_vector(x,*n,*incx).dot(make_vector(y,*n,*incy))); - else if(*incx<0 && *incy>0) *res = (make_vector(x,*n,-*incx).reverse().dot(make_vector(y,*n,*incy))); - else if(*incx>0 && *incy<0) *res = (make_vector(x,*n,*incx).dot(make_vector(y,*n,-*incy).reverse())); - else if(*incx<0 && *incy<0) *res = (make_vector(x,*n,-*incx).reverse().dot(make_vector(y,*n,-*incy).reverse())); - return 0; -} - -// computes a vector-vector dot product without complex conjugation. -int EIGEN_BLAS_FUNC(dotuw)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar* pres) -{ - Scalar* res = reinterpret_cast<Scalar*>(pres); - - if(*n<=0) - { - *res = Scalar(0); - return 0; - } - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - - if(*incx==1 && *incy==1) *res = (make_vector(x,*n).cwiseProduct(make_vector(y,*n))).sum(); - else if(*incx>0 && *incy>0) *res = (make_vector(x,*n,*incx).cwiseProduct(make_vector(y,*n,*incy))).sum(); - else if(*incx<0 && *incy>0) *res = (make_vector(x,*n,-*incx).reverse().cwiseProduct(make_vector(y,*n,*incy))).sum(); - else if(*incx>0 && *incy<0) *res = (make_vector(x,*n,*incx).cwiseProduct(make_vector(y,*n,-*incy).reverse())).sum(); - else if(*incx<0 && *incy<0) *res = (make_vector(x,*n,-*incx).reverse().cwiseProduct(make_vector(y,*n,-*incy).reverse())).sum(); - return 0; -} - -RealScalar EIGEN_CAT(EIGEN_CAT(REAL_SCALAR_SUFFIX,SCALAR_SUFFIX),nrm2_)(int *n, RealScalar *px, int *incx) -{ -// std::cerr << "__nrm2 " << *n << " " << *incx << "\n"; - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - - if(*incx==1) - return make_vector(x,*n).stableNorm(); - - return make_vector(x,*n,*incx).stableNorm(); -} - -int EIGEN_CAT(EIGEN_CAT(SCALAR_SUFFIX,REAL_SCALAR_SUFFIX),rot_)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pc, RealScalar *ps) -{ - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - RealScalar c = *pc; - RealScalar s = *ps; - - StridedVectorType vx(make_vector(x,*n,std::abs(*incx))); - StridedVectorType vy(make_vector(y,*n,std::abs(*incy))); - - Reverse<StridedVectorType> rvx(vx); - Reverse<StridedVectorType> rvy(vy); - - // TODO implement mixed real-scalar rotations - if(*incx<0 && *incy>0) internal::apply_rotation_in_the_plane(rvx, vy, JacobiRotation<Scalar>(c,s)); - else if(*incx>0 && *incy<0) internal::apply_rotation_in_the_plane(vx, rvy, JacobiRotation<Scalar>(c,s)); - else internal::apply_rotation_in_the_plane(vx, vy, JacobiRotation<Scalar>(c,s)); - - return 0; -} - -int EIGEN_CAT(EIGEN_CAT(SCALAR_SUFFIX,REAL_SCALAR_SUFFIX),scal_)(int *n, RealScalar *palpha, RealScalar *px, int *incx) -{ - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - RealScalar alpha = *palpha; - -// std::cerr << "__scal " << *n << " " << alpha << " " << *incx << "\n"; - - if(*incx==1) make_vector(x,*n) *= alpha; - else make_vector(x,*n,std::abs(*incx)) *= alpha; - - return 0; -} diff --git a/eigen/blas/level1_impl.h b/eigen/blas/level1_impl.h deleted file mode 100644 index f857bfa..0000000 --- a/eigen/blas/level1_impl.h +++ /dev/null @@ -1,166 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009-2010 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#include "common.h" - -int EIGEN_BLAS_FUNC(axpy)(const int *n, const RealScalar *palpha, const RealScalar *px, const int *incx, RealScalar *py, const int *incy) -{ - const Scalar* x = reinterpret_cast<const Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - - if(*n<=0) return 0; - - if(*incx==1 && *incy==1) make_vector(y,*n) += alpha * make_vector(x,*n); - else if(*incx>0 && *incy>0) make_vector(y,*n,*incy) += alpha * make_vector(x,*n,*incx); - else if(*incx>0 && *incy<0) make_vector(y,*n,-*incy).reverse() += alpha * make_vector(x,*n,*incx); - else if(*incx<0 && *incy>0) make_vector(y,*n,*incy) += alpha * make_vector(x,*n,-*incx).reverse(); - else if(*incx<0 && *incy<0) make_vector(y,*n,-*incy).reverse() += alpha * make_vector(x,*n,-*incx).reverse(); - - return 0; -} - -int EIGEN_BLAS_FUNC(copy)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy) -{ - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - - // be carefull, *incx==0 is allowed !! - if(*incx==1 && *incy==1) - make_vector(y,*n) = make_vector(x,*n); - else - { - if(*incx<0) x = x - (*n-1)*(*incx); - if(*incy<0) y = y - (*n-1)*(*incy); - for(int i=0;i<*n;++i) - { - *y = *x; - x += *incx; - y += *incy; - } - } - - return 0; -} - -int EIGEN_CAT(EIGEN_CAT(i,SCALAR_SUFFIX),amax_)(int *n, RealScalar *px, int *incx) -{ - if(*n<=0) return 0; - Scalar* x = reinterpret_cast<Scalar*>(px); - - DenseIndex ret; - if(*incx==1) make_vector(x,*n).cwiseAbs().maxCoeff(&ret); - else make_vector(x,*n,std::abs(*incx)).cwiseAbs().maxCoeff(&ret); - return int(ret)+1; -} - -int EIGEN_CAT(EIGEN_CAT(i,SCALAR_SUFFIX),amin_)(int *n, RealScalar *px, int *incx) -{ - if(*n<=0) return 0; - Scalar* x = reinterpret_cast<Scalar*>(px); - - DenseIndex ret; - if(*incx==1) make_vector(x,*n).cwiseAbs().minCoeff(&ret); - else make_vector(x,*n,std::abs(*incx)).cwiseAbs().minCoeff(&ret); - return int(ret)+1; -} - -int EIGEN_BLAS_FUNC(rotg)(RealScalar *pa, RealScalar *pb, RealScalar *pc, RealScalar *ps) -{ - using std::sqrt; - using std::abs; - - Scalar& a = *reinterpret_cast<Scalar*>(pa); - Scalar& b = *reinterpret_cast<Scalar*>(pb); - RealScalar* c = pc; - Scalar* s = reinterpret_cast<Scalar*>(ps); - - #if !ISCOMPLEX - Scalar r,z; - Scalar aa = abs(a); - Scalar ab = abs(b); - if((aa+ab)==Scalar(0)) - { - *c = 1; - *s = 0; - r = 0; - z = 0; - } - else - { - r = sqrt(a*a + b*b); - Scalar amax = aa>ab ? a : b; - r = amax>0 ? r : -r; - *c = a/r; - *s = b/r; - z = 1; - if (aa > ab) z = *s; - if (ab > aa && *c!=RealScalar(0)) - z = Scalar(1)/ *c; - } - *pa = r; - *pb = z; - #else - Scalar alpha; - RealScalar norm,scale; - if(abs(a)==RealScalar(0)) - { - *c = RealScalar(0); - *s = Scalar(1); - a = b; - } - else - { - scale = abs(a) + abs(b); - norm = scale*sqrt((numext::abs2(a/scale)) + (numext::abs2(b/scale))); - alpha = a/abs(a); - *c = abs(a)/norm; - *s = alpha*numext::conj(b)/norm; - a = alpha*norm; - } - #endif - -// JacobiRotation<Scalar> r; -// r.makeGivens(a,b); -// *c = r.c(); -// *s = r.s(); - - return 0; -} - -int EIGEN_BLAS_FUNC(scal)(int *n, RealScalar *palpha, RealScalar *px, int *incx) -{ - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar alpha = *reinterpret_cast<Scalar*>(palpha); - - if(*incx==1) make_vector(x,*n) *= alpha; - else make_vector(x,*n,std::abs(*incx)) *= alpha; - - return 0; -} - -int EIGEN_BLAS_FUNC(swap)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy) -{ - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - - if(*incx==1 && *incy==1) make_vector(y,*n).swap(make_vector(x,*n)); - else if(*incx>0 && *incy>0) make_vector(y,*n,*incy).swap(make_vector(x,*n,*incx)); - else if(*incx>0 && *incy<0) make_vector(y,*n,-*incy).reverse().swap(make_vector(x,*n,*incx)); - else if(*incx<0 && *incy>0) make_vector(y,*n,*incy).swap(make_vector(x,*n,-*incx).reverse()); - else if(*incx<0 && *incy<0) make_vector(y,*n,-*incy).reverse().swap(make_vector(x,*n,-*incx).reverse()); - - return 1; -} diff --git a/eigen/blas/level1_real_impl.h b/eigen/blas/level1_real_impl.h deleted file mode 100644 index 02586d5..0000000 --- a/eigen/blas/level1_real_impl.h +++ /dev/null @@ -1,100 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009-2010 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#include "common.h" - -// computes the sum of magnitudes of all vector elements or, for a complex vector x, the sum -// res = |Rex1| + |Imx1| + |Rex2| + |Imx2| + ... + |Rexn| + |Imxn|, where x is a vector of order n -RealScalar EIGEN_BLAS_FUNC(asum)(int *n, RealScalar *px, int *incx) -{ -// std::cerr << "_asum " << *n << " " << *incx << "\n"; - - Scalar* x = reinterpret_cast<Scalar*>(px); - - if(*n<=0) return 0; - - if(*incx==1) return make_vector(x,*n).cwiseAbs().sum(); - else return make_vector(x,*n,std::abs(*incx)).cwiseAbs().sum(); -} - -// computes a vector-vector dot product. -Scalar EIGEN_BLAS_FUNC(dot)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy) -{ -// std::cerr << "_dot " << *n << " " << *incx << " " << *incy << "\n"; - - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - - if(*incx==1 && *incy==1) return (make_vector(x,*n).cwiseProduct(make_vector(y,*n))).sum(); - else if(*incx>0 && *incy>0) return (make_vector(x,*n,*incx).cwiseProduct(make_vector(y,*n,*incy))).sum(); - else if(*incx<0 && *incy>0) return (make_vector(x,*n,-*incx).reverse().cwiseProduct(make_vector(y,*n,*incy))).sum(); - else if(*incx>0 && *incy<0) return (make_vector(x,*n,*incx).cwiseProduct(make_vector(y,*n,-*incy).reverse())).sum(); - else if(*incx<0 && *incy<0) return (make_vector(x,*n,-*incx).reverse().cwiseProduct(make_vector(y,*n,-*incy).reverse())).sum(); - else return 0; -} - -// computes the Euclidean norm of a vector. -// FIXME -Scalar EIGEN_BLAS_FUNC(nrm2)(int *n, RealScalar *px, int *incx) -{ -// std::cerr << "_nrm2 " << *n << " " << *incx << "\n"; - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - - if(*incx==1) return make_vector(x,*n).stableNorm(); - else return make_vector(x,*n,std::abs(*incx)).stableNorm(); -} - -int EIGEN_BLAS_FUNC(rot)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pc, RealScalar *ps) -{ -// std::cerr << "_rot " << *n << " " << *incx << " " << *incy << "\n"; - if(*n<=0) return 0; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar c = *reinterpret_cast<Scalar*>(pc); - Scalar s = *reinterpret_cast<Scalar*>(ps); - - StridedVectorType vx(make_vector(x,*n,std::abs(*incx))); - StridedVectorType vy(make_vector(y,*n,std::abs(*incy))); - - Reverse<StridedVectorType> rvx(vx); - Reverse<StridedVectorType> rvy(vy); - - if(*incx<0 && *incy>0) internal::apply_rotation_in_the_plane(rvx, vy, JacobiRotation<Scalar>(c,s)); - else if(*incx>0 && *incy<0) internal::apply_rotation_in_the_plane(vx, rvy, JacobiRotation<Scalar>(c,s)); - else internal::apply_rotation_in_the_plane(vx, vy, JacobiRotation<Scalar>(c,s)); - - - return 0; -} - -/* -// performs rotation of points in the modified plane. -int EIGEN_BLAS_FUNC(rotm)(int *n, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *param) -{ - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - - // TODO - - return 0; -} - -// computes the modified parameters for a Givens rotation. -int EIGEN_BLAS_FUNC(rotmg)(RealScalar *d1, RealScalar *d2, RealScalar *x1, RealScalar *x2, RealScalar *param) -{ - // TODO - - return 0; -} -*/ diff --git a/eigen/blas/level2_cplx_impl.h b/eigen/blas/level2_cplx_impl.h deleted file mode 100644 index e3ce614..0000000 --- a/eigen/blas/level2_cplx_impl.h +++ /dev/null @@ -1,360 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009-2010 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#include "common.h" - -/** ZHEMV performs the matrix-vector operation - * - * y := alpha*A*x + beta*y, - * - * where alpha and beta are scalars, x and y are n element vectors and - * A is an n by n hermitian matrix. - */ -int EIGEN_BLAS_FUNC(hemv)(const char *uplo, const int *n, const RealScalar *palpha, const RealScalar *pa, const int *lda, - const RealScalar *px, const int *incx, const RealScalar *pbeta, RealScalar *py, const int *incy) -{ - typedef void (*functype)(int, const Scalar*, int, const Scalar*, Scalar*, Scalar); - static const functype func[2] = { - // array index: UP - (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Upper,false,false>::run), - // array index: LO - (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Lower,false,false>::run), - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* x = reinterpret_cast<const Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - - // check arguments - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*lda<std::max(1,*n)) info = 5; - else if(*incx==0) info = 7; - else if(*incy==0) info = 10; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"HEMV ",&info,6); - - if(*n==0) - return 1; - - const Scalar* actual_x = get_compact_vector(x,*n,*incx); - Scalar* actual_y = get_compact_vector(y,*n,*incy); - - if(beta!=Scalar(1)) - { - if(beta==Scalar(0)) make_vector(actual_y, *n).setZero(); - else make_vector(actual_y, *n) *= beta; - } - - if(alpha!=Scalar(0)) - { - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, a, *lda, actual_x, actual_y, alpha); - } - - if(actual_x!=x) delete[] actual_x; - if(actual_y!=y) delete[] copy_back(actual_y,y,*n,*incy); - - return 1; -} - -/** ZHBMV performs the matrix-vector operation - * - * y := alpha*A*x + beta*y, - * - * where alpha and beta are scalars, x and y are n element vectors and - * A is an n by n hermitian band matrix, with k super-diagonals. - */ -// int EIGEN_BLAS_FUNC(hbmv)(char *uplo, int *n, int *k, RealScalar *alpha, RealScalar *a, int *lda, -// RealScalar *x, int *incx, RealScalar *beta, RealScalar *y, int *incy) -// { -// return 1; -// } - -/** ZHPMV performs the matrix-vector operation - * - * y := alpha*A*x + beta*y, - * - * where alpha and beta are scalars, x and y are n element vectors and - * A is an n by n hermitian matrix, supplied in packed form. - */ -// int EIGEN_BLAS_FUNC(hpmv)(char *uplo, int *n, RealScalar *alpha, RealScalar *ap, RealScalar *x, int *incx, RealScalar *beta, RealScalar *y, int *incy) -// { -// return 1; -// } - -/** ZHPR performs the hermitian rank 1 operation - * - * A := alpha*x*conjg( x' ) + A, - * - * where alpha is a real scalar, x is an n element vector and A is an - * n by n hermitian matrix, supplied in packed form. - */ -int EIGEN_BLAS_FUNC(hpr)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *pap) -{ - typedef void (*functype)(int, Scalar*, const Scalar*, RealScalar); - static const functype func[2] = { - // array index: UP - (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run), - // array index: LO - (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run), - }; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* ap = reinterpret_cast<Scalar*>(pap); - RealScalar alpha = *palpha; - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"HPR ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x, *n, *incx); - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, ap, x_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - - return 1; -} - -/** ZHPR2 performs the hermitian rank 2 operation - * - * A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, - * - * where alpha is a scalar, x and y are n element vectors and A is an - * n by n hermitian matrix, supplied in packed form. - */ -int EIGEN_BLAS_FUNC(hpr2)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pap) -{ - typedef void (*functype)(int, Scalar*, const Scalar*, const Scalar*, Scalar); - static const functype func[2] = { - // array index: UP - (internal::packed_rank2_update_selector<Scalar,int,Upper>::run), - // array index: LO - (internal::packed_rank2_update_selector<Scalar,int,Lower>::run), - }; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar* ap = reinterpret_cast<Scalar*>(pap); - Scalar alpha = *reinterpret_cast<Scalar*>(palpha); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*incy==0) info = 7; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"HPR2 ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x, *n, *incx); - Scalar* y_cpy = get_compact_vector(y, *n, *incy); - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, ap, x_cpy, y_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - if(y_cpy!=y) delete[] y_cpy; - - return 1; -} - -/** ZHER performs the hermitian rank 1 operation - * - * A := alpha*x*conjg( x' ) + A, - * - * where alpha is a real scalar, x is an n element vector and A is an - * n by n hermitian matrix. - */ -int EIGEN_BLAS_FUNC(her)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *pa, int *lda) -{ - typedef void (*functype)(int, Scalar*, int, const Scalar*, const Scalar*, const Scalar&); - static const functype func[2] = { - // array index: UP - (selfadjoint_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run), - // array index: LO - (selfadjoint_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run), - }; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* a = reinterpret_cast<Scalar*>(pa); - RealScalar alpha = *reinterpret_cast<RealScalar*>(palpha); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*lda<std::max(1,*n)) info = 7; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"HER ",&info,6); - - if(alpha==RealScalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x, *n, *incx); - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, a, *lda, x_cpy, x_cpy, alpha); - - matrix(a,*n,*n,*lda).diagonal().imag().setZero(); - - if(x_cpy!=x) delete[] x_cpy; - - return 1; -} - -/** ZHER2 performs the hermitian rank 2 operation - * - * A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, - * - * where alpha is a scalar, x and y are n element vectors and A is an n - * by n hermitian matrix. - */ -int EIGEN_BLAS_FUNC(her2)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pa, int *lda) -{ - typedef void (*functype)(int, Scalar*, int, const Scalar*, const Scalar*, Scalar); - static const functype func[2] = { - // array index: UP - (internal::rank2_update_selector<Scalar,int,Upper>::run), - // array index: LO - (internal::rank2_update_selector<Scalar,int,Lower>::run), - }; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar* a = reinterpret_cast<Scalar*>(pa); - Scalar alpha = *reinterpret_cast<Scalar*>(palpha); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*incy==0) info = 7; - else if(*lda<std::max(1,*n)) info = 9; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"HER2 ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x, *n, *incx); - Scalar* y_cpy = get_compact_vector(y, *n, *incy); - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, a, *lda, x_cpy, y_cpy, alpha); - - matrix(a,*n,*n,*lda).diagonal().imag().setZero(); - - if(x_cpy!=x) delete[] x_cpy; - if(y_cpy!=y) delete[] y_cpy; - - return 1; -} - -/** ZGERU performs the rank 1 operation - * - * A := alpha*x*y' + A, - * - * where alpha is a scalar, x is an m element vector, y is an n element - * vector and A is an m by n matrix. - */ -int EIGEN_BLAS_FUNC(geru)(int *m, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pa, int *lda) -{ - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar* a = reinterpret_cast<Scalar*>(pa); - Scalar alpha = *reinterpret_cast<Scalar*>(palpha); - - int info = 0; - if(*m<0) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*incy==0) info = 7; - else if(*lda<std::max(1,*m)) info = 9; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"GERU ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x,*m,*incx); - Scalar* y_cpy = get_compact_vector(y,*n,*incy); - - internal::general_rank1_update<Scalar,int,ColMajor,false,false>::run(*m, *n, a, *lda, x_cpy, y_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - if(y_cpy!=y) delete[] y_cpy; - - return 1; -} - -/** ZGERC performs the rank 1 operation - * - * A := alpha*x*conjg( y' ) + A, - * - * where alpha is a scalar, x is an m element vector, y is an n element - * vector and A is an m by n matrix. - */ -int EIGEN_BLAS_FUNC(gerc)(int *m, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pa, int *lda) -{ - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar* a = reinterpret_cast<Scalar*>(pa); - Scalar alpha = *reinterpret_cast<Scalar*>(palpha); - - int info = 0; - if(*m<0) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*incy==0) info = 7; - else if(*lda<std::max(1,*m)) info = 9; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"GERC ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x,*m,*incx); - Scalar* y_cpy = get_compact_vector(y,*n,*incy); - - internal::general_rank1_update<Scalar,int,ColMajor,false,Conj>::run(*m, *n, a, *lda, x_cpy, y_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - if(y_cpy!=y) delete[] y_cpy; - - return 1; -} diff --git a/eigen/blas/level2_impl.h b/eigen/blas/level2_impl.h deleted file mode 100644 index 173f40b..0000000 --- a/eigen/blas/level2_impl.h +++ /dev/null @@ -1,553 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009-2010 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#include "common.h" - -template<typename Index, typename Scalar, int StorageOrder, bool ConjugateLhs, bool ConjugateRhs> -struct general_matrix_vector_product_wrapper -{ - static void run(Index rows, Index cols,const Scalar *lhs, Index lhsStride, const Scalar *rhs, Index rhsIncr, Scalar* res, Index resIncr, Scalar alpha) - { - typedef internal::const_blas_data_mapper<Scalar,Index,StorageOrder> LhsMapper; - typedef internal::const_blas_data_mapper<Scalar,Index,RowMajor> RhsMapper; - - internal::general_matrix_vector_product - <Index,Scalar,LhsMapper,StorageOrder,ConjugateLhs,Scalar,RhsMapper,ConjugateRhs>::run( - rows, cols, LhsMapper(lhs, lhsStride), RhsMapper(rhs, rhsIncr), res, resIncr, alpha); - } -}; - -int EIGEN_BLAS_FUNC(gemv)(const char *opa, const int *m, const int *n, const RealScalar *palpha, - const RealScalar *pa, const int *lda, const RealScalar *pb, const int *incb, const RealScalar *pbeta, RealScalar *pc, const int *incc) -{ - typedef void (*functype)(int, int, const Scalar *, int, const Scalar *, int , Scalar *, int, Scalar); - static const functype func[4] = { - // array index: NOTR - (general_matrix_vector_product_wrapper<int,Scalar,ColMajor,false,false>::run), - // array index: TR - (general_matrix_vector_product_wrapper<int,Scalar,RowMajor,false,false>::run), - // array index: ADJ - (general_matrix_vector_product_wrapper<int,Scalar,RowMajor,Conj ,false>::run), - 0 - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* b = reinterpret_cast<const Scalar*>(pb); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - - // check arguments - int info = 0; - if(OP(*opa)==INVALID) info = 1; - else if(*m<0) info = 2; - else if(*n<0) info = 3; - else if(*lda<std::max(1,*m)) info = 6; - else if(*incb==0) info = 8; - else if(*incc==0) info = 11; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"GEMV ",&info,6); - - if(*m==0 || *n==0 || (alpha==Scalar(0) && beta==Scalar(1))) - return 0; - - int actual_m = *m; - int actual_n = *n; - int code = OP(*opa); - if(code!=NOTR) - std::swap(actual_m,actual_n); - - const Scalar* actual_b = get_compact_vector(b,actual_n,*incb); - Scalar* actual_c = get_compact_vector(c,actual_m,*incc); - - if(beta!=Scalar(1)) - { - if(beta==Scalar(0)) make_vector(actual_c, actual_m).setZero(); - else make_vector(actual_c, actual_m) *= beta; - } - - if(code>=4 || func[code]==0) - return 0; - - func[code](actual_m, actual_n, a, *lda, actual_b, 1, actual_c, 1, alpha); - - if(actual_b!=b) delete[] actual_b; - if(actual_c!=c) delete[] copy_back(actual_c,c,actual_m,*incc); - - return 1; -} - -int EIGEN_BLAS_FUNC(trsv)(const char *uplo, const char *opa, const char *diag, const int *n, const RealScalar *pa, const int *lda, RealScalar *pb, const int *incb) -{ - typedef void (*functype)(int, const Scalar *, int, Scalar *); - static const functype func[16] = { - // array index: NOTR | (UP << 2) | (NUNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,ColMajor>::run), - // array index: TR | (UP << 2) | (NUNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,RowMajor>::run), - // array index: ADJ | (UP << 2) | (NUNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, Conj, RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (NUNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,ColMajor>::run), - // array index: TR | (LO << 2) | (NUNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,RowMajor>::run), - // array index: ADJ | (LO << 2) | (NUNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, Conj, RowMajor>::run), - 0, - // array index: NOTR | (UP << 2) | (UNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,ColMajor>::run), - // array index: TR | (UP << 2) | (UNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,RowMajor>::run), - // array index: ADJ | (UP << 2) | (UNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,Conj, RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (UNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,ColMajor>::run), - // array index: TR | (LO << 2) | (UNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,RowMajor>::run), - // array index: ADJ | (LO << 2) | (UNIT << 3) - (internal::triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,Conj, RowMajor>::run), - 0 - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - Scalar* b = reinterpret_cast<Scalar*>(pb); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(OP(*opa)==INVALID) info = 2; - else if(DIAG(*diag)==INVALID) info = 3; - else if(*n<0) info = 4; - else if(*lda<std::max(1,*n)) info = 6; - else if(*incb==0) info = 8; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"TRSV ",&info,6); - - Scalar* actual_b = get_compact_vector(b,*n,*incb); - - int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3); - func[code](*n, a, *lda, actual_b); - - if(actual_b!=b) delete[] copy_back(actual_b,b,*n,*incb); - - return 0; -} - - - -int EIGEN_BLAS_FUNC(trmv)(const char *uplo, const char *opa, const char *diag, const int *n, const RealScalar *pa, const int *lda, RealScalar *pb, const int *incb) -{ - typedef void (*functype)(int, int, const Scalar *, int, const Scalar *, int, Scalar *, int, const Scalar&); - static const functype func[16] = { - // array index: NOTR | (UP << 2) | (NUNIT << 3) - (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,ColMajor>::run), - // array index: TR | (UP << 2) | (NUNIT << 3) - (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,RowMajor>::run), - // array index: ADJ | (UP << 2) | (NUNIT << 3) - (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,Conj, Scalar,false,RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (NUNIT << 3) - (internal::triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,ColMajor>::run), - // array index: TR | (LO << 2) | (NUNIT << 3) - (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,RowMajor>::run), - // array index: ADJ | (LO << 2) | (NUNIT << 3) - (internal::triangular_matrix_vector_product<int,Upper|0, Scalar,Conj, Scalar,false,RowMajor>::run), - 0, - // array index: NOTR | (UP << 2) | (UNIT << 3) - (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run), - // array index: TR | (UP << 2) | (UNIT << 3) - (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run), - // array index: ADJ | (UP << 2) | (UNIT << 3) - (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (UNIT << 3) - (internal::triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run), - // array index: TR | (LO << 2) | (UNIT << 3) - (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run), - // array index: ADJ | (LO << 2) | (UNIT << 3) - (internal::triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run), - 0 - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - Scalar* b = reinterpret_cast<Scalar*>(pb); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(OP(*opa)==INVALID) info = 2; - else if(DIAG(*diag)==INVALID) info = 3; - else if(*n<0) info = 4; - else if(*lda<std::max(1,*n)) info = 6; - else if(*incb==0) info = 8; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"TRMV ",&info,6); - - if(*n==0) - return 1; - - Scalar* actual_b = get_compact_vector(b,*n,*incb); - Matrix<Scalar,Dynamic,1> res(*n); - res.setZero(); - - int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3); - if(code>=16 || func[code]==0) - return 0; - - func[code](*n, *n, a, *lda, actual_b, 1, res.data(), 1, Scalar(1)); - - copy_back(res.data(),b,*n,*incb); - if(actual_b!=b) delete[] actual_b; - - return 1; -} - -/** GBMV performs one of the matrix-vector operations - * - * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, - * - * where alpha and beta are scalars, x and y are vectors and A is an - * m by n band matrix, with kl sub-diagonals and ku super-diagonals. - */ -int EIGEN_BLAS_FUNC(gbmv)(char *trans, int *m, int *n, int *kl, int *ku, RealScalar *palpha, RealScalar *pa, int *lda, - RealScalar *px, int *incx, RealScalar *pbeta, RealScalar *py, int *incy) -{ - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* x = reinterpret_cast<const Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - int coeff_rows = *kl+*ku+1; - - int info = 0; - if(OP(*trans)==INVALID) info = 1; - else if(*m<0) info = 2; - else if(*n<0) info = 3; - else if(*kl<0) info = 4; - else if(*ku<0) info = 5; - else if(*lda<coeff_rows) info = 8; - else if(*incx==0) info = 10; - else if(*incy==0) info = 13; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"GBMV ",&info,6); - - if(*m==0 || *n==0 || (alpha==Scalar(0) && beta==Scalar(1))) - return 0; - - int actual_m = *m; - int actual_n = *n; - if(OP(*trans)!=NOTR) - std::swap(actual_m,actual_n); - - const Scalar* actual_x = get_compact_vector(x,actual_n,*incx); - Scalar* actual_y = get_compact_vector(y,actual_m,*incy); - - if(beta!=Scalar(1)) - { - if(beta==Scalar(0)) make_vector(actual_y, actual_m).setZero(); - else make_vector(actual_y, actual_m) *= beta; - } - - ConstMatrixType mat_coeffs(a,coeff_rows,*n,*lda); - - int nb = std::min(*n,(*m)+(*ku)); - for(int j=0; j<nb; ++j) - { - int start = std::max(0,j - *ku); - int end = std::min((*m)-1,j + *kl); - int len = end - start + 1; - int offset = (*ku) - j + start; - if(OP(*trans)==NOTR) - make_vector(actual_y+start,len) += (alpha*actual_x[j]) * mat_coeffs.col(j).segment(offset,len); - else if(OP(*trans)==TR) - actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).transpose() * make_vector(actual_x+start,len) ).value(); - else - actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).adjoint() * make_vector(actual_x+start,len) ).value(); - } - - if(actual_x!=x) delete[] actual_x; - if(actual_y!=y) delete[] copy_back(actual_y,y,actual_m,*incy); - - return 0; -} - -#if 0 -/** TBMV performs one of the matrix-vector operations - * - * x := A*x, or x := A'*x, - * - * where x is an n element vector and A is an n by n unit, or non-unit, - * upper or lower triangular band matrix, with ( k + 1 ) diagonals. - */ -int EIGEN_BLAS_FUNC(tbmv)(char *uplo, char *opa, char *diag, int *n, int *k, RealScalar *pa, int *lda, RealScalar *px, int *incx) -{ - Scalar* a = reinterpret_cast<Scalar*>(pa); - Scalar* x = reinterpret_cast<Scalar*>(px); - int coeff_rows = *k + 1; - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(OP(*opa)==INVALID) info = 2; - else if(DIAG(*diag)==INVALID) info = 3; - else if(*n<0) info = 4; - else if(*k<0) info = 5; - else if(*lda<coeff_rows) info = 7; - else if(*incx==0) info = 9; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"TBMV ",&info,6); - - if(*n==0) - return 0; - - int actual_n = *n; - - Scalar* actual_x = get_compact_vector(x,actual_n,*incx); - - MatrixType mat_coeffs(a,coeff_rows,*n,*lda); - - int ku = UPLO(*uplo)==UPPER ? *k : 0; - int kl = UPLO(*uplo)==LOWER ? *k : 0; - - for(int j=0; j<*n; ++j) - { - int start = std::max(0,j - ku); - int end = std::min((*m)-1,j + kl); - int len = end - start + 1; - int offset = (ku) - j + start; - - if(OP(*trans)==NOTR) - make_vector(actual_y+start,len) += (alpha*actual_x[j]) * mat_coeffs.col(j).segment(offset,len); - else if(OP(*trans)==TR) - actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).transpose() * make_vector(actual_x+start,len) ).value(); - else - actual_y[j] += alpha * ( mat_coeffs.col(j).segment(offset,len).adjoint() * make_vector(actual_x+start,len) ).value(); - } - - if(actual_x!=x) delete[] actual_x; - if(actual_y!=y) delete[] copy_back(actual_y,y,actual_m,*incy); - - return 0; -} -#endif - -/** DTBSV solves one of the systems of equations - * - * A*x = b, or A'*x = b, - * - * where b and x are n element vectors and A is an n by n unit, or - * non-unit, upper or lower triangular band matrix, with ( k + 1 ) - * diagonals. - * - * No test for singularity or near-singularity is included in this - * routine. Such tests must be performed before calling this routine. - */ -int EIGEN_BLAS_FUNC(tbsv)(char *uplo, char *op, char *diag, int *n, int *k, RealScalar *pa, int *lda, RealScalar *px, int *incx) -{ - typedef void (*functype)(int, int, const Scalar *, int, Scalar *); - static const functype func[16] = { - // array index: NOTR | (UP << 2) | (NUNIT << 3) - (internal::band_solve_triangular_selector<int,Upper|0, Scalar,false,Scalar,ColMajor>::run), - // array index: TR | (UP << 2) | (NUNIT << 3) - (internal::band_solve_triangular_selector<int,Lower|0, Scalar,false,Scalar,RowMajor>::run), - // array index: ADJ | (UP << 2) | (NUNIT << 3) - (internal::band_solve_triangular_selector<int,Lower|0, Scalar,Conj, Scalar,RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (NUNIT << 3) - (internal::band_solve_triangular_selector<int,Lower|0, Scalar,false,Scalar,ColMajor>::run), - // array index: TR | (LO << 2) | (NUNIT << 3) - (internal::band_solve_triangular_selector<int,Upper|0, Scalar,false,Scalar,RowMajor>::run), - // array index: ADJ | (LO << 2) | (NUNIT << 3) - (internal::band_solve_triangular_selector<int,Upper|0, Scalar,Conj, Scalar,RowMajor>::run), - 0, - // array index: NOTR | (UP << 2) | (UNIT << 3) - (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,false,Scalar,ColMajor>::run), - // array index: TR | (UP << 2) | (UNIT << 3) - (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,false,Scalar,RowMajor>::run), - // array index: ADJ | (UP << 2) | (UNIT << 3) - (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,Conj, Scalar,RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (UNIT << 3) - (internal::band_solve_triangular_selector<int,Lower|UnitDiag,Scalar,false,Scalar,ColMajor>::run), - // array index: TR | (LO << 2) | (UNIT << 3) - (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,false,Scalar,RowMajor>::run), - // array index: ADJ | (LO << 2) | (UNIT << 3) - (internal::band_solve_triangular_selector<int,Upper|UnitDiag,Scalar,Conj, Scalar,RowMajor>::run), - 0, - }; - - Scalar* a = reinterpret_cast<Scalar*>(pa); - Scalar* x = reinterpret_cast<Scalar*>(px); - int coeff_rows = *k+1; - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(OP(*op)==INVALID) info = 2; - else if(DIAG(*diag)==INVALID) info = 3; - else if(*n<0) info = 4; - else if(*k<0) info = 5; - else if(*lda<coeff_rows) info = 7; - else if(*incx==0) info = 9; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"TBSV ",&info,6); - - if(*n==0 || (*k==0 && DIAG(*diag)==UNIT)) - return 0; - - int actual_n = *n; - - Scalar* actual_x = get_compact_vector(x,actual_n,*incx); - - int code = OP(*op) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3); - if(code>=16 || func[code]==0) - return 0; - - func[code](*n, *k, a, *lda, actual_x); - - if(actual_x!=x) delete[] copy_back(actual_x,x,actual_n,*incx); - - return 0; -} - -/** DTPMV performs one of the matrix-vector operations - * - * x := A*x, or x := A'*x, - * - * where x is an n element vector and A is an n by n unit, or non-unit, - * upper or lower triangular matrix, supplied in packed form. - */ -int EIGEN_BLAS_FUNC(tpmv)(char *uplo, char *opa, char *diag, int *n, RealScalar *pap, RealScalar *px, int *incx) -{ - typedef void (*functype)(int, const Scalar*, const Scalar*, Scalar*, Scalar); - static const functype func[16] = { - // array index: NOTR | (UP << 2) | (NUNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,ColMajor>::run), - // array index: TR | (UP << 2) | (NUNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,RowMajor>::run), - // array index: ADJ | (UP << 2) | (NUNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,Conj, Scalar,false,RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (NUNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Lower|0, Scalar,false,Scalar,false,ColMajor>::run), - // array index: TR | (LO << 2) | (NUNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,false,Scalar,false,RowMajor>::run), - // array index: ADJ | (LO << 2) | (NUNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Upper|0, Scalar,Conj, Scalar,false,RowMajor>::run), - 0, - // array index: NOTR | (UP << 2) | (UNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run), - // array index: TR | (UP << 2) | (UNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run), - // array index: ADJ | (UP << 2) | (UNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (UNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Lower|UnitDiag,Scalar,false,Scalar,false,ColMajor>::run), - // array index: TR | (LO << 2) | (UNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,false,Scalar,false,RowMajor>::run), - // array index: ADJ | (LO << 2) | (UNIT << 3) - (internal::packed_triangular_matrix_vector_product<int,Upper|UnitDiag,Scalar,Conj, Scalar,false,RowMajor>::run), - 0 - }; - - Scalar* ap = reinterpret_cast<Scalar*>(pap); - Scalar* x = reinterpret_cast<Scalar*>(px); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(OP(*opa)==INVALID) info = 2; - else if(DIAG(*diag)==INVALID) info = 3; - else if(*n<0) info = 4; - else if(*incx==0) info = 7; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"TPMV ",&info,6); - - if(*n==0) - return 1; - - Scalar* actual_x = get_compact_vector(x,*n,*incx); - Matrix<Scalar,Dynamic,1> res(*n); - res.setZero(); - - int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3); - if(code>=16 || func[code]==0) - return 0; - - func[code](*n, ap, actual_x, res.data(), Scalar(1)); - - copy_back(res.data(),x,*n,*incx); - if(actual_x!=x) delete[] actual_x; - - return 1; -} - -/** DTPSV solves one of the systems of equations - * - * A*x = b, or A'*x = b, - * - * where b and x are n element vectors and A is an n by n unit, or - * non-unit, upper or lower triangular matrix, supplied in packed form. - * - * No test for singularity or near-singularity is included in this - * routine. Such tests must be performed before calling this routine. - */ -int EIGEN_BLAS_FUNC(tpsv)(char *uplo, char *opa, char *diag, int *n, RealScalar *pap, RealScalar *px, int *incx) -{ - typedef void (*functype)(int, const Scalar*, Scalar*); - static const functype func[16] = { - // array index: NOTR | (UP << 2) | (NUNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,ColMajor>::run), - // array index: TR | (UP << 2) | (NUNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,RowMajor>::run), - // array index: ADJ | (UP << 2) | (NUNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, Conj, RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (NUNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|0, false,ColMajor>::run), - // array index: TR | (LO << 2) | (NUNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, false,RowMajor>::run), - // array index: ADJ | (LO << 2) | (NUNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|0, Conj, RowMajor>::run), - 0, - // array index: NOTR | (UP << 2) | (UNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,ColMajor>::run), - // array index: TR | (UP << 2) | (UNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,RowMajor>::run), - // array index: ADJ | (UP << 2) | (UNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,Conj, RowMajor>::run), - 0, - // array index: NOTR | (LO << 2) | (UNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Lower|UnitDiag,false,ColMajor>::run), - // array index: TR | (LO << 2) | (UNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,false,RowMajor>::run), - // array index: ADJ | (LO << 2) | (UNIT << 3) - (internal::packed_triangular_solve_vector<Scalar,Scalar,int,OnTheLeft, Upper|UnitDiag,Conj, RowMajor>::run), - 0 - }; - - Scalar* ap = reinterpret_cast<Scalar*>(pap); - Scalar* x = reinterpret_cast<Scalar*>(px); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(OP(*opa)==INVALID) info = 2; - else if(DIAG(*diag)==INVALID) info = 3; - else if(*n<0) info = 4; - else if(*incx==0) info = 7; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"TPSV ",&info,6); - - Scalar* actual_x = get_compact_vector(x,*n,*incx); - - int code = OP(*opa) | (UPLO(*uplo) << 2) | (DIAG(*diag) << 3); - func[code](*n, ap, actual_x); - - if(actual_x!=x) delete[] copy_back(actual_x,x,*n,*incx); - - return 1; -} diff --git a/eigen/blas/level2_real_impl.h b/eigen/blas/level2_real_impl.h deleted file mode 100644 index 7620f0a..0000000 --- a/eigen/blas/level2_real_impl.h +++ /dev/null @@ -1,306 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009-2010 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#include "common.h" - -// y = alpha*A*x + beta*y -int EIGEN_BLAS_FUNC(symv) (const char *uplo, const int *n, const RealScalar *palpha, const RealScalar *pa, const int *lda, - const RealScalar *px, const int *incx, const RealScalar *pbeta, RealScalar *py, const int *incy) -{ - typedef void (*functype)(int, const Scalar*, int, const Scalar*, Scalar*, Scalar); - static const functype func[2] = { - // array index: UP - (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Upper,false,false>::run), - // array index: LO - (internal::selfadjoint_matrix_vector_product<Scalar,int,ColMajor,Lower,false,false>::run), - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* x = reinterpret_cast<const Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - - // check arguments - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*lda<std::max(1,*n)) info = 5; - else if(*incx==0) info = 7; - else if(*incy==0) info = 10; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"SYMV ",&info,6); - - if(*n==0) - return 0; - - const Scalar* actual_x = get_compact_vector(x,*n,*incx); - Scalar* actual_y = get_compact_vector(y,*n,*incy); - - if(beta!=Scalar(1)) - { - if(beta==Scalar(0)) make_vector(actual_y, *n).setZero(); - else make_vector(actual_y, *n) *= beta; - } - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, a, *lda, actual_x, actual_y, alpha); - - if(actual_x!=x) delete[] actual_x; - if(actual_y!=y) delete[] copy_back(actual_y,y,*n,*incy); - - return 1; -} - -// C := alpha*x*x' + C -int EIGEN_BLAS_FUNC(syr)(const char *uplo, const int *n, const RealScalar *palpha, const RealScalar *px, const int *incx, RealScalar *pc, const int *ldc) -{ - - typedef void (*functype)(int, Scalar*, int, const Scalar*, const Scalar*, const Scalar&); - static const functype func[2] = { - // array index: UP - (selfadjoint_rank1_update<Scalar,int,ColMajor,Upper,false,Conj>::run), - // array index: LO - (selfadjoint_rank1_update<Scalar,int,ColMajor,Lower,false,Conj>::run), - }; - - const Scalar* x = reinterpret_cast<const Scalar*>(px); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*ldc<std::max(1,*n)) info = 7; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"SYR ",&info,6); - - if(*n==0 || alpha==Scalar(0)) return 1; - - // if the increment is not 1, let's copy it to a temporary vector to enable vectorization - const Scalar* x_cpy = get_compact_vector(x,*n,*incx); - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, c, *ldc, x_cpy, x_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - - return 1; -} - -// C := alpha*x*y' + alpha*y*x' + C -int EIGEN_BLAS_FUNC(syr2)(const char *uplo, const int *n, const RealScalar *palpha, const RealScalar *px, const int *incx, const RealScalar *py, const int *incy, RealScalar *pc, const int *ldc) -{ - typedef void (*functype)(int, Scalar*, int, const Scalar*, const Scalar*, Scalar); - static const functype func[2] = { - // array index: UP - (internal::rank2_update_selector<Scalar,int,Upper>::run), - // array index: LO - (internal::rank2_update_selector<Scalar,int,Lower>::run), - }; - - const Scalar* x = reinterpret_cast<const Scalar*>(px); - const Scalar* y = reinterpret_cast<const Scalar*>(py); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*incy==0) info = 7; - else if(*ldc<std::max(1,*n)) info = 9; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"SYR2 ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - const Scalar* x_cpy = get_compact_vector(x,*n,*incx); - const Scalar* y_cpy = get_compact_vector(y,*n,*incy); - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, c, *ldc, x_cpy, y_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - if(y_cpy!=y) delete[] y_cpy; - -// int code = UPLO(*uplo); -// if(code>=2 || func[code]==0) -// return 0; - -// func[code](*n, a, *inca, b, *incb, c, *ldc, alpha); - return 1; -} - -/** DSBMV performs the matrix-vector operation - * - * y := alpha*A*x + beta*y, - * - * where alpha and beta are scalars, x and y are n element vectors and - * A is an n by n symmetric band matrix, with k super-diagonals. - */ -// int EIGEN_BLAS_FUNC(sbmv)( char *uplo, int *n, int *k, RealScalar *alpha, RealScalar *a, int *lda, -// RealScalar *x, int *incx, RealScalar *beta, RealScalar *y, int *incy) -// { -// return 1; -// } - - -/** DSPMV performs the matrix-vector operation - * - * y := alpha*A*x + beta*y, - * - * where alpha and beta are scalars, x and y are n element vectors and - * A is an n by n symmetric matrix, supplied in packed form. - * - */ -// int EIGEN_BLAS_FUNC(spmv)(char *uplo, int *n, RealScalar *alpha, RealScalar *ap, RealScalar *x, int *incx, RealScalar *beta, RealScalar *y, int *incy) -// { -// return 1; -// } - -/** DSPR performs the symmetric rank 1 operation - * - * A := alpha*x*x' + A, - * - * where alpha is a real scalar, x is an n element vector and A is an - * n by n symmetric matrix, supplied in packed form. - */ -int EIGEN_BLAS_FUNC(spr)(char *uplo, int *n, Scalar *palpha, Scalar *px, int *incx, Scalar *pap) -{ - typedef void (*functype)(int, Scalar*, const Scalar*, Scalar); - static const functype func[2] = { - // array index: UP - (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Upper,false,false>::run), - // array index: LO - (internal::selfadjoint_packed_rank1_update<Scalar,int,ColMajor,Lower,false,false>::run), - }; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* ap = reinterpret_cast<Scalar*>(pap); - Scalar alpha = *reinterpret_cast<Scalar*>(palpha); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"SPR ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x, *n, *incx); - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, ap, x_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - - return 1; -} - -/** DSPR2 performs the symmetric rank 2 operation - * - * A := alpha*x*y' + alpha*y*x' + A, - * - * where alpha is a scalar, x and y are n element vectors and A is an - * n by n symmetric matrix, supplied in packed form. - */ -int EIGEN_BLAS_FUNC(spr2)(char *uplo, int *n, RealScalar *palpha, RealScalar *px, int *incx, RealScalar *py, int *incy, RealScalar *pap) -{ - typedef void (*functype)(int, Scalar*, const Scalar*, const Scalar*, Scalar); - static const functype func[2] = { - // array index: UP - (internal::packed_rank2_update_selector<Scalar,int,Upper>::run), - // array index: LO - (internal::packed_rank2_update_selector<Scalar,int,Lower>::run), - }; - - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar* ap = reinterpret_cast<Scalar*>(pap); - Scalar alpha = *reinterpret_cast<Scalar*>(palpha); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*incy==0) info = 7; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"SPR2 ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x, *n, *incx); - Scalar* y_cpy = get_compact_vector(y, *n, *incy); - - int code = UPLO(*uplo); - if(code>=2 || func[code]==0) - return 0; - - func[code](*n, ap, x_cpy, y_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - if(y_cpy!=y) delete[] y_cpy; - - return 1; -} - -/** DGER performs the rank 1 operation - * - * A := alpha*x*y' + A, - * - * where alpha is a scalar, x is an m element vector, y is an n element - * vector and A is an m by n matrix. - */ -int EIGEN_BLAS_FUNC(ger)(int *m, int *n, Scalar *palpha, Scalar *px, int *incx, Scalar *py, int *incy, Scalar *pa, int *lda) -{ - Scalar* x = reinterpret_cast<Scalar*>(px); - Scalar* y = reinterpret_cast<Scalar*>(py); - Scalar* a = reinterpret_cast<Scalar*>(pa); - Scalar alpha = *reinterpret_cast<Scalar*>(palpha); - - int info = 0; - if(*m<0) info = 1; - else if(*n<0) info = 2; - else if(*incx==0) info = 5; - else if(*incy==0) info = 7; - else if(*lda<std::max(1,*m)) info = 9; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"GER ",&info,6); - - if(alpha==Scalar(0)) - return 1; - - Scalar* x_cpy = get_compact_vector(x,*m,*incx); - Scalar* y_cpy = get_compact_vector(y,*n,*incy); - - internal::general_rank1_update<Scalar,int,ColMajor,false,false>::run(*m, *n, a, *lda, x_cpy, y_cpy, alpha); - - if(x_cpy!=x) delete[] x_cpy; - if(y_cpy!=y) delete[] y_cpy; - - return 1; -} diff --git a/eigen/blas/level3_impl.h b/eigen/blas/level3_impl.h deleted file mode 100644 index 6c802cd..0000000 --- a/eigen/blas/level3_impl.h +++ /dev/null @@ -1,702 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009-2010 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. -#include <iostream> -#include "common.h" - -int EIGEN_BLAS_FUNC(gemm)(const char *opa, const char *opb, const int *m, const int *n, const int *k, const RealScalar *palpha, - const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc) -{ -// std::cerr << "in gemm " << *opa << " " << *opb << " " << *m << " " << *n << " " << *k << " " << *lda << " " << *ldb << " " << *ldc << " " << *palpha << " " << *pbeta << "\n"; - typedef void (*functype)(DenseIndex, DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, Scalar, internal::level3_blocking<Scalar,Scalar>&, Eigen::internal::GemmParallelInfo<DenseIndex>*); - static const functype func[12] = { - // array index: NOTR | (NOTR << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,ColMajor,false,ColMajor>::run), - // array index: TR | (NOTR << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,false,ColMajor>::run), - // array index: ADJ | (NOTR << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor>::run), - 0, - // array index: NOTR | (TR << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,false,ColMajor>::run), - // array index: TR | (TR << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,RowMajor,false,ColMajor>::run), - // array index: ADJ | (TR << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,RowMajor,false,ColMajor>::run), - 0, - // array index: NOTR | (ADJ << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor>::run), - // array index: TR | (ADJ << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,false,Scalar,RowMajor,Conj, ColMajor>::run), - // array index: ADJ | (ADJ << 2) - (internal::general_matrix_matrix_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,RowMajor,Conj, ColMajor>::run), - 0 - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* b = reinterpret_cast<const Scalar*>(pb); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - - int info = 0; - if(OP(*opa)==INVALID) info = 1; - else if(OP(*opb)==INVALID) info = 2; - else if(*m<0) info = 3; - else if(*n<0) info = 4; - else if(*k<0) info = 5; - else if(*lda<std::max(1,(OP(*opa)==NOTR)?*m:*k)) info = 8; - else if(*ldb<std::max(1,(OP(*opb)==NOTR)?*k:*n)) info = 10; - else if(*ldc<std::max(1,*m)) info = 13; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"GEMM ",&info,6); - - if (*m == 0 || *n == 0) - return 0; - - if(beta!=Scalar(1)) - { - if(beta==Scalar(0)) matrix(c, *m, *n, *ldc).setZero(); - else matrix(c, *m, *n, *ldc) *= beta; - } - - if(*k == 0) - return 0; - - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*m,*n,*k,1,true); - - int code = OP(*opa) | (OP(*opb) << 2); - func[code](*m, *n, *k, a, *lda, b, *ldb, c, *ldc, alpha, blocking, 0); - return 0; -} - -int EIGEN_BLAS_FUNC(trsm)(const char *side, const char *uplo, const char *opa, const char *diag, const int *m, const int *n, - const RealScalar *palpha, const RealScalar *pa, const int *lda, RealScalar *pb, const int *ldb) -{ -// std::cerr << "in trsm " << *side << " " << *uplo << " " << *opa << " " << *diag << " " << *m << "," << *n << " " << *palpha << " " << *lda << " " << *ldb<< "\n"; - typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, internal::level3_blocking<Scalar,Scalar>&); - static const functype func[32] = { - // array index: NOTR | (LEFT << 2) | (UP << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, false,ColMajor,ColMajor>::run), - // array index: TR | (LEFT << 2) | (UP << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, false,RowMajor,ColMajor>::run), - // array index: ADJ | (LEFT << 2) | (UP << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, Conj, RowMajor,ColMajor>::run),\ - 0, - // array index: NOTR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, false,ColMajor,ColMajor>::run), - // array index: TR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, false,RowMajor,ColMajor>::run), - // array index: ADJ | (RIGHT << 2) | (UP << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, Conj, RowMajor,ColMajor>::run), - 0, - // array index: NOTR | (LEFT << 2) | (LO << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|0, false,ColMajor,ColMajor>::run), - // array index: TR | (LEFT << 2) | (LO << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, false,RowMajor,ColMajor>::run), - // array index: ADJ | (LEFT << 2) | (LO << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|0, Conj, RowMajor,ColMajor>::run), - 0, - // array index: NOTR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|0, false,ColMajor,ColMajor>::run), - // array index: TR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, false,RowMajor,ColMajor>::run), - // array index: ADJ | (RIGHT << 2) | (LO << 3) | (NUNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|0, Conj, RowMajor,ColMajor>::run), - 0, - // array index: NOTR | (LEFT << 2) | (UP << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,false,ColMajor,ColMajor>::run), - // array index: TR | (LEFT << 2) | (UP << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,false,RowMajor,ColMajor>::run), - // array index: ADJ | (LEFT << 2) | (UP << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,Conj, RowMajor,ColMajor>::run), - 0, - // array index: NOTR | (RIGHT << 2) | (UP << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,false,ColMajor,ColMajor>::run), - // array index: TR | (RIGHT << 2) | (UP << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,false,RowMajor,ColMajor>::run), - // array index: ADJ | (RIGHT << 2) | (UP << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,Conj, RowMajor,ColMajor>::run), - 0, - // array index: NOTR | (LEFT << 2) | (LO << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Lower|UnitDiag,false,ColMajor,ColMajor>::run), - // array index: TR | (LEFT << 2) | (LO << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,false,RowMajor,ColMajor>::run), - // array index: ADJ | (LEFT << 2) | (LO << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheLeft, Upper|UnitDiag,Conj, RowMajor,ColMajor>::run), - 0, - // array index: NOTR | (RIGHT << 2) | (LO << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Lower|UnitDiag,false,ColMajor,ColMajor>::run), - // array index: TR | (RIGHT << 2) | (LO << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,false,RowMajor,ColMajor>::run), - // array index: ADJ | (RIGHT << 2) | (LO << 3) | (UNIT << 4) - (internal::triangular_solve_matrix<Scalar,DenseIndex,OnTheRight,Upper|UnitDiag,Conj, RowMajor,ColMajor>::run), - 0 - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - Scalar* b = reinterpret_cast<Scalar*>(pb); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - - int info = 0; - if(SIDE(*side)==INVALID) info = 1; - else if(UPLO(*uplo)==INVALID) info = 2; - else if(OP(*opa)==INVALID) info = 3; - else if(DIAG(*diag)==INVALID) info = 4; - else if(*m<0) info = 5; - else if(*n<0) info = 6; - else if(*lda<std::max(1,(SIDE(*side)==LEFT)?*m:*n)) info = 9; - else if(*ldb<std::max(1,*m)) info = 11; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"TRSM ",&info,6); - - if(*m==0 || *n==0) - return 0; - - int code = OP(*opa) | (SIDE(*side) << 2) | (UPLO(*uplo) << 3) | (DIAG(*diag) << 4); - - if(SIDE(*side)==LEFT) - { - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*m,1,false); - func[code](*m, *n, a, *lda, b, *ldb, blocking); - } - else - { - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*n,1,false); - func[code](*n, *m, a, *lda, b, *ldb, blocking); - } - - if(alpha!=Scalar(1)) - matrix(b,*m,*n,*ldb) *= alpha; - - return 0; -} - - -// b = alpha*op(a)*b for side = 'L'or'l' -// b = alpha*b*op(a) for side = 'R'or'r' -int EIGEN_BLAS_FUNC(trmm)(const char *side, const char *uplo, const char *opa, const char *diag, const int *m, const int *n, - const RealScalar *palpha, const RealScalar *pa, const int *lda, RealScalar *pb, const int *ldb) -{ -// std::cerr << "in trmm " << *side << " " << *uplo << " " << *opa << " " << *diag << " " << *m << " " << *n << " " << *lda << " " << *ldb << " " << *palpha << "\n"; - typedef void (*functype)(DenseIndex, DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, const Scalar&, internal::level3_blocking<Scalar,Scalar>&); - static const functype func[32] = { - // array index: NOTR | (LEFT << 2) | (UP << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, ColMajor,false,ColMajor,false,ColMajor>::run), - // array index: TR | (LEFT << 2) | (UP << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, RowMajor,false,ColMajor,false,ColMajor>::run), - // array index: ADJ | (LEFT << 2) | (UP << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, RowMajor,Conj, ColMajor,false,ColMajor>::run), - 0, - // array index: NOTR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,ColMajor,false,ColMajor>::run), - // array index: TR | (RIGHT << 2) | (UP << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,RowMajor,false,ColMajor>::run), - // array index: ADJ | (RIGHT << 2) | (UP << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,RowMajor,Conj, ColMajor>::run), - 0, - // array index: NOTR | (LEFT << 2) | (LO << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, true, ColMajor,false,ColMajor,false,ColMajor>::run), - // array index: TR | (LEFT << 2) | (LO << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, RowMajor,false,ColMajor,false,ColMajor>::run), - // array index: ADJ | (LEFT << 2) | (LO << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, true, RowMajor,Conj, ColMajor,false,ColMajor>::run), - 0, - // array index: NOTR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|0, false,ColMajor,false,ColMajor,false,ColMajor>::run), - // array index: TR | (RIGHT << 2) | (LO << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,RowMajor,false,ColMajor>::run), - // array index: ADJ | (RIGHT << 2) | (LO << 3) | (NUNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|0, false,ColMajor,false,RowMajor,Conj, ColMajor>::run), - 0, - // array index: NOTR | (LEFT << 2) | (UP << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, ColMajor,false,ColMajor,false,ColMajor>::run), - // array index: TR | (LEFT << 2) | (UP << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, RowMajor,false,ColMajor,false,ColMajor>::run), - // array index: ADJ | (LEFT << 2) | (UP << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, RowMajor,Conj, ColMajor,false,ColMajor>::run), - 0, - // array index: NOTR | (RIGHT << 2) | (UP << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,ColMajor,false,ColMajor>::run), - // array index: TR | (RIGHT << 2) | (UP << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,RowMajor,false,ColMajor>::run), - // array index: ADJ | (RIGHT << 2) | (UP << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,RowMajor,Conj, ColMajor>::run), - 0, - // array index: NOTR | (LEFT << 2) | (LO << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,true, ColMajor,false,ColMajor,false,ColMajor>::run), - // array index: TR | (LEFT << 2) | (LO << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, RowMajor,false,ColMajor,false,ColMajor>::run), - // array index: ADJ | (LEFT << 2) | (LO << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,true, RowMajor,Conj, ColMajor,false,ColMajor>::run), - 0, - // array index: NOTR | (RIGHT << 2) | (LO << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Lower|UnitDiag,false,ColMajor,false,ColMajor,false,ColMajor>::run), - // array index: TR | (RIGHT << 2) | (LO << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,RowMajor,false,ColMajor>::run), - // array index: ADJ | (RIGHT << 2) | (LO << 3) | (UNIT << 4) - (internal::product_triangular_matrix_matrix<Scalar,DenseIndex,Upper|UnitDiag,false,ColMajor,false,RowMajor,Conj, ColMajor>::run), - 0 - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - Scalar* b = reinterpret_cast<Scalar*>(pb); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - - int info = 0; - if(SIDE(*side)==INVALID) info = 1; - else if(UPLO(*uplo)==INVALID) info = 2; - else if(OP(*opa)==INVALID) info = 3; - else if(DIAG(*diag)==INVALID) info = 4; - else if(*m<0) info = 5; - else if(*n<0) info = 6; - else if(*lda<std::max(1,(SIDE(*side)==LEFT)?*m:*n)) info = 9; - else if(*ldb<std::max(1,*m)) info = 11; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"TRMM ",&info,6); - - int code = OP(*opa) | (SIDE(*side) << 2) | (UPLO(*uplo) << 3) | (DIAG(*diag) << 4); - - if(*m==0 || *n==0) - return 1; - - // FIXME find a way to avoid this copy - Matrix<Scalar,Dynamic,Dynamic,ColMajor> tmp = matrix(b,*m,*n,*ldb); - matrix(b,*m,*n,*ldb).setZero(); - - if(SIDE(*side)==LEFT) - { - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*m,1,false); - func[code](*m, *n, *m, a, *lda, tmp.data(), tmp.outerStride(), b, *ldb, alpha, blocking); - } - else - { - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic,4> blocking(*m,*n,*n,1,false); - func[code](*m, *n, *n, tmp.data(), tmp.outerStride(), a, *lda, b, *ldb, alpha, blocking); - } - return 1; -} - -// c = alpha*a*b + beta*c for side = 'L'or'l' -// c = alpha*b*a + beta*c for side = 'R'or'r -int EIGEN_BLAS_FUNC(symm)(const char *side, const char *uplo, const int *m, const int *n, const RealScalar *palpha, - const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc) -{ -// std::cerr << "in symm " << *side << " " << *uplo << " " << *m << "x" << *n << " lda:" << *lda << " ldb:" << *ldb << " ldc:" << *ldc << " alpha:" << *palpha << " beta:" << *pbeta << "\n"; - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* b = reinterpret_cast<const Scalar*>(pb); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - - int info = 0; - if(SIDE(*side)==INVALID) info = 1; - else if(UPLO(*uplo)==INVALID) info = 2; - else if(*m<0) info = 3; - else if(*n<0) info = 4; - else if(*lda<std::max(1,(SIDE(*side)==LEFT)?*m:*n)) info = 7; - else if(*ldb<std::max(1,*m)) info = 9; - else if(*ldc<std::max(1,*m)) info = 12; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"SYMM ",&info,6); - - if(beta!=Scalar(1)) - { - if(beta==Scalar(0)) matrix(c, *m, *n, *ldc).setZero(); - else matrix(c, *m, *n, *ldc) *= beta; - } - - if(*m==0 || *n==0) - { - return 1; - } - - int size = (SIDE(*side)==LEFT) ? (*m) : (*n); - #if ISCOMPLEX - // FIXME add support for symmetric complex matrix - Matrix<Scalar,Dynamic,Dynamic,ColMajor> matA(size,size); - if(UPLO(*uplo)==UP) - { - matA.triangularView<Upper>() = matrix(a,size,size,*lda); - matA.triangularView<Lower>() = matrix(a,size,size,*lda).transpose(); - } - else if(UPLO(*uplo)==LO) - { - matA.triangularView<Lower>() = matrix(a,size,size,*lda); - matA.triangularView<Upper>() = matrix(a,size,size,*lda).transpose(); - } - if(SIDE(*side)==LEFT) - matrix(c, *m, *n, *ldc) += alpha * matA * matrix(b, *m, *n, *ldb); - else if(SIDE(*side)==RIGHT) - matrix(c, *m, *n, *ldc) += alpha * matrix(b, *m, *n, *ldb) * matA; - #else - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*m,*n,size,1,false); - - if(SIDE(*side)==LEFT) - if(UPLO(*uplo)==UP) internal::product_selfadjoint_matrix<Scalar, DenseIndex, RowMajor,true,false, ColMajor,false,false, ColMajor>::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha, blocking); - else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,true,false, ColMajor,false,false, ColMajor>::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha, blocking); - else return 0; - else if(SIDE(*side)==RIGHT) - if(UPLO(*uplo)==UP) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,false,false, RowMajor,true,false, ColMajor>::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha, blocking); - else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar, DenseIndex, ColMajor,false,false, ColMajor,true,false, ColMajor>::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha, blocking); - else return 0; - else - return 0; - #endif - - return 0; -} - -// c = alpha*a*a' + beta*c for op = 'N'or'n' -// c = alpha*a'*a + beta*c for op = 'T'or't','C'or'c' -int EIGEN_BLAS_FUNC(syrk)(const char *uplo, const char *op, const int *n, const int *k, - const RealScalar *palpha, const RealScalar *pa, const int *lda, const RealScalar *pbeta, RealScalar *pc, const int *ldc) -{ -// std::cerr << "in syrk " << *uplo << " " << *op << " " << *n << " " << *k << " " << *palpha << " " << *lda << " " << *pbeta << " " << *ldc << "\n"; - #if !ISCOMPLEX - typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, const Scalar&, internal::level3_blocking<Scalar,Scalar>&); - static const functype func[8] = { - // array index: NOTR | (UP << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,ColMajor,Conj, Upper>::run), - // array index: TR | (UP << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,ColMajor,Conj, Upper>::run), - // array index: ADJ | (UP << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,ColMajor,false,Upper>::run), - 0, - // array index: NOTR | (LO << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,ColMajor,Conj, Lower>::run), - // array index: TR | (LO << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,false,Scalar,ColMajor,ColMajor,Conj, Lower>::run), - // array index: ADJ | (LO << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,ColMajor,false,Lower>::run), - 0 - }; - #endif - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(OP(*op)==INVALID || (ISCOMPLEX && OP(*op)==ADJ) ) info = 2; - else if(*n<0) info = 3; - else if(*k<0) info = 4; - else if(*lda<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 7; - else if(*ldc<std::max(1,*n)) info = 10; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"SYRK ",&info,6); - - if(beta!=Scalar(1)) - { - if(UPLO(*uplo)==UP) - if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Upper>().setZero(); - else matrix(c, *n, *n, *ldc).triangularView<Upper>() *= beta; - else - if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Lower>().setZero(); - else matrix(c, *n, *n, *ldc).triangularView<Lower>() *= beta; - } - - if(*n==0 || *k==0) - return 0; - - #if ISCOMPLEX - // FIXME add support for symmetric complex matrix - if(UPLO(*uplo)==UP) - { - if(OP(*op)==NOTR) - matrix(c, *n, *n, *ldc).triangularView<Upper>() += alpha * matrix(a,*n,*k,*lda) * matrix(a,*n,*k,*lda).transpose(); - else - matrix(c, *n, *n, *ldc).triangularView<Upper>() += alpha * matrix(a,*k,*n,*lda).transpose() * matrix(a,*k,*n,*lda); - } - else - { - if(OP(*op)==NOTR) - matrix(c, *n, *n, *ldc).triangularView<Lower>() += alpha * matrix(a,*n,*k,*lda) * matrix(a,*n,*k,*lda).transpose(); - else - matrix(c, *n, *n, *ldc).triangularView<Lower>() += alpha * matrix(a,*k,*n,*lda).transpose() * matrix(a,*k,*n,*lda); - } - #else - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*n,*n,*k,1,false); - - int code = OP(*op) | (UPLO(*uplo) << 2); - func[code](*n, *k, a, *lda, a, *lda, c, *ldc, alpha, blocking); - #endif - - return 0; -} - -// c = alpha*a*b' + alpha*b*a' + beta*c for op = 'N'or'n' -// c = alpha*a'*b + alpha*b'*a + beta*c for op = 'T'or't' -int EIGEN_BLAS_FUNC(syr2k)(const char *uplo, const char *op, const int *n, const int *k, const RealScalar *palpha, - const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc) -{ - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* b = reinterpret_cast<const Scalar*>(pb); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - -// std::cerr << "in syr2k " << *uplo << " " << *op << " " << *n << " " << *k << " " << alpha << " " << *lda << " " << *ldb << " " << beta << " " << *ldc << "\n"; - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if(OP(*op)==INVALID || (ISCOMPLEX && OP(*op)==ADJ) ) info = 2; - else if(*n<0) info = 3; - else if(*k<0) info = 4; - else if(*lda<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 7; - else if(*ldb<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 9; - else if(*ldc<std::max(1,*n)) info = 12; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"SYR2K",&info,6); - - if(beta!=Scalar(1)) - { - if(UPLO(*uplo)==UP) - if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Upper>().setZero(); - else matrix(c, *n, *n, *ldc).triangularView<Upper>() *= beta; - else - if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Lower>().setZero(); - else matrix(c, *n, *n, *ldc).triangularView<Lower>() *= beta; - } - - if(*k==0) - return 1; - - if(OP(*op)==NOTR) - { - if(UPLO(*uplo)==UP) - { - matrix(c, *n, *n, *ldc).triangularView<Upper>() - += alpha *matrix(a, *n, *k, *lda)*matrix(b, *n, *k, *ldb).transpose() - + alpha*matrix(b, *n, *k, *ldb)*matrix(a, *n, *k, *lda).transpose(); - } - else if(UPLO(*uplo)==LO) - matrix(c, *n, *n, *ldc).triangularView<Lower>() - += alpha*matrix(a, *n, *k, *lda)*matrix(b, *n, *k, *ldb).transpose() - + alpha*matrix(b, *n, *k, *ldb)*matrix(a, *n, *k, *lda).transpose(); - } - else if(OP(*op)==TR || OP(*op)==ADJ) - { - if(UPLO(*uplo)==UP) - matrix(c, *n, *n, *ldc).triangularView<Upper>() - += alpha*matrix(a, *k, *n, *lda).transpose()*matrix(b, *k, *n, *ldb) - + alpha*matrix(b, *k, *n, *ldb).transpose()*matrix(a, *k, *n, *lda); - else if(UPLO(*uplo)==LO) - matrix(c, *n, *n, *ldc).triangularView<Lower>() - += alpha*matrix(a, *k, *n, *lda).transpose()*matrix(b, *k, *n, *ldb) - + alpha*matrix(b, *k, *n, *ldb).transpose()*matrix(a, *k, *n, *lda); - } - - return 0; -} - - -#if ISCOMPLEX - -// c = alpha*a*b + beta*c for side = 'L'or'l' -// c = alpha*b*a + beta*c for side = 'R'or'r -int EIGEN_BLAS_FUNC(hemm)(const char *side, const char *uplo, const int *m, const int *n, const RealScalar *palpha, - const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc) -{ - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* b = reinterpret_cast<const Scalar*>(pb); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - Scalar beta = *reinterpret_cast<const Scalar*>(pbeta); - -// std::cerr << "in hemm " << *side << " " << *uplo << " " << *m << " " << *n << " " << alpha << " " << *lda << " " << beta << " " << *ldc << "\n"; - - int info = 0; - if(SIDE(*side)==INVALID) info = 1; - else if(UPLO(*uplo)==INVALID) info = 2; - else if(*m<0) info = 3; - else if(*n<0) info = 4; - else if(*lda<std::max(1,(SIDE(*side)==LEFT)?*m:*n)) info = 7; - else if(*ldb<std::max(1,*m)) info = 9; - else if(*ldc<std::max(1,*m)) info = 12; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"HEMM ",&info,6); - - if(beta==Scalar(0)) matrix(c, *m, *n, *ldc).setZero(); - else if(beta!=Scalar(1)) matrix(c, *m, *n, *ldc) *= beta; - - if(*m==0 || *n==0) - { - return 1; - } - - int size = (SIDE(*side)==LEFT) ? (*m) : (*n); - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*m,*n,size,1,false); - - if(SIDE(*side)==LEFT) - { - if(UPLO(*uplo)==UP) internal::product_selfadjoint_matrix<Scalar,DenseIndex,RowMajor,true,Conj, ColMajor,false,false, ColMajor> - ::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha, blocking); - else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar,DenseIndex,ColMajor,true,false, ColMajor,false,false, ColMajor> - ::run(*m, *n, a, *lda, b, *ldb, c, *ldc, alpha, blocking); - else return 0; - } - else if(SIDE(*side)==RIGHT) - { - if(UPLO(*uplo)==UP) matrix(c,*m,*n,*ldc) += alpha * matrix(b,*m,*n,*ldb) * matrix(a,*n,*n,*lda).selfadjointView<Upper>();/*internal::product_selfadjoint_matrix<Scalar,DenseIndex,ColMajor,false,false, RowMajor,true,Conj, ColMajor> - ::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha, blocking);*/ - else if(UPLO(*uplo)==LO) internal::product_selfadjoint_matrix<Scalar,DenseIndex,ColMajor,false,false, ColMajor,true,false, ColMajor> - ::run(*m, *n, b, *ldb, a, *lda, c, *ldc, alpha, blocking); - else return 0; - } - else - { - return 0; - } - - return 0; -} - -// c = alpha*a*conj(a') + beta*c for op = 'N'or'n' -// c = alpha*conj(a')*a + beta*c for op = 'C'or'c' -int EIGEN_BLAS_FUNC(herk)(const char *uplo, const char *op, const int *n, const int *k, - const RealScalar *palpha, const RealScalar *pa, const int *lda, const RealScalar *pbeta, RealScalar *pc, const int *ldc) -{ -// std::cerr << "in herk " << *uplo << " " << *op << " " << *n << " " << *k << " " << *palpha << " " << *lda << " " << *pbeta << " " << *ldc << "\n"; - - typedef void (*functype)(DenseIndex, DenseIndex, const Scalar *, DenseIndex, const Scalar *, DenseIndex, Scalar *, DenseIndex, const Scalar&, internal::level3_blocking<Scalar,Scalar>&); - static const functype func[8] = { - // array index: NOTR | (UP << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor,Upper>::run), - 0, - // array index: ADJ | (UP << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,Upper>::run), - 0, - // array index: NOTR | (LO << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,ColMajor,false,Scalar,RowMajor,Conj, ColMajor,Lower>::run), - 0, - // array index: ADJ | (LO << 2) - (internal::general_matrix_matrix_triangular_product<DenseIndex,Scalar,RowMajor,Conj, Scalar,ColMajor,false,ColMajor,Lower>::run), - 0 - }; - - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - Scalar* c = reinterpret_cast<Scalar*>(pc); - RealScalar alpha = *palpha; - RealScalar beta = *pbeta; - -// std::cerr << "in herk " << *uplo << " " << *op << " " << *n << " " << *k << " " << alpha << " " << *lda << " " << beta << " " << *ldc << "\n"; - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if((OP(*op)==INVALID) || (OP(*op)==TR)) info = 2; - else if(*n<0) info = 3; - else if(*k<0) info = 4; - else if(*lda<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 7; - else if(*ldc<std::max(1,*n)) info = 10; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"HERK ",&info,6); - - int code = OP(*op) | (UPLO(*uplo) << 2); - - if(beta!=RealScalar(1)) - { - if(UPLO(*uplo)==UP) - if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Upper>().setZero(); - else matrix(c, *n, *n, *ldc).triangularView<StrictlyUpper>() *= beta; - else - if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Lower>().setZero(); - else matrix(c, *n, *n, *ldc).triangularView<StrictlyLower>() *= beta; - - if(beta!=Scalar(0)) - { - matrix(c, *n, *n, *ldc).diagonal().real() *= beta; - matrix(c, *n, *n, *ldc).diagonal().imag().setZero(); - } - } - - if(*k>0 && alpha!=RealScalar(0)) - { - internal::gemm_blocking_space<ColMajor,Scalar,Scalar,Dynamic,Dynamic,Dynamic> blocking(*n,*n,*k,1,false); - func[code](*n, *k, a, *lda, a, *lda, c, *ldc, alpha, blocking); - matrix(c, *n, *n, *ldc).diagonal().imag().setZero(); - } - return 0; -} - -// c = alpha*a*conj(b') + conj(alpha)*b*conj(a') + beta*c, for op = 'N'or'n' -// c = alpha*conj(a')*b + conj(alpha)*conj(b')*a + beta*c, for op = 'C'or'c' -int EIGEN_BLAS_FUNC(her2k)(const char *uplo, const char *op, const int *n, const int *k, - const RealScalar *palpha, const RealScalar *pa, const int *lda, const RealScalar *pb, const int *ldb, const RealScalar *pbeta, RealScalar *pc, const int *ldc) -{ - const Scalar* a = reinterpret_cast<const Scalar*>(pa); - const Scalar* b = reinterpret_cast<const Scalar*>(pb); - Scalar* c = reinterpret_cast<Scalar*>(pc); - Scalar alpha = *reinterpret_cast<const Scalar*>(palpha); - RealScalar beta = *pbeta; - -// std::cerr << "in her2k " << *uplo << " " << *op << " " << *n << " " << *k << " " << alpha << " " << *lda << " " << *ldb << " " << beta << " " << *ldc << "\n"; - - int info = 0; - if(UPLO(*uplo)==INVALID) info = 1; - else if((OP(*op)==INVALID) || (OP(*op)==TR)) info = 2; - else if(*n<0) info = 3; - else if(*k<0) info = 4; - else if(*lda<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 7; - else if(*ldb<std::max(1,(OP(*op)==NOTR)?*n:*k)) info = 9; - else if(*ldc<std::max(1,*n)) info = 12; - if(info) - return xerbla_(SCALAR_SUFFIX_UP"HER2K",&info,6); - - if(beta!=RealScalar(1)) - { - if(UPLO(*uplo)==UP) - if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Upper>().setZero(); - else matrix(c, *n, *n, *ldc).triangularView<StrictlyUpper>() *= beta; - else - if(beta==Scalar(0)) matrix(c, *n, *n, *ldc).triangularView<Lower>().setZero(); - else matrix(c, *n, *n, *ldc).triangularView<StrictlyLower>() *= beta; - - if(beta!=Scalar(0)) - { - matrix(c, *n, *n, *ldc).diagonal().real() *= beta; - matrix(c, *n, *n, *ldc).diagonal().imag().setZero(); - } - } - else if(*k>0 && alpha!=Scalar(0)) - matrix(c, *n, *n, *ldc).diagonal().imag().setZero(); - - if(*k==0) - return 1; - - if(OP(*op)==NOTR) - { - if(UPLO(*uplo)==UP) - { - matrix(c, *n, *n, *ldc).triangularView<Upper>() - += alpha *matrix(a, *n, *k, *lda)*matrix(b, *n, *k, *ldb).adjoint() - + numext::conj(alpha)*matrix(b, *n, *k, *ldb)*matrix(a, *n, *k, *lda).adjoint(); - } - else if(UPLO(*uplo)==LO) - matrix(c, *n, *n, *ldc).triangularView<Lower>() - += alpha*matrix(a, *n, *k, *lda)*matrix(b, *n, *k, *ldb).adjoint() - + numext::conj(alpha)*matrix(b, *n, *k, *ldb)*matrix(a, *n, *k, *lda).adjoint(); - } - else if(OP(*op)==ADJ) - { - if(UPLO(*uplo)==UP) - matrix(c, *n, *n, *ldc).triangularView<Upper>() - += alpha*matrix(a, *k, *n, *lda).adjoint()*matrix(b, *k, *n, *ldb) - + numext::conj(alpha)*matrix(b, *k, *n, *ldb).adjoint()*matrix(a, *k, *n, *lda); - else if(UPLO(*uplo)==LO) - matrix(c, *n, *n, *ldc).triangularView<Lower>() - += alpha*matrix(a, *k, *n, *lda).adjoint()*matrix(b, *k, *n, *ldb) - + numext::conj(alpha)*matrix(b, *k, *n, *ldb).adjoint()*matrix(a, *k, *n, *lda); - } - - return 1; -} - -#endif // ISCOMPLEX diff --git a/eigen/blas/single.cpp b/eigen/blas/single.cpp deleted file mode 100644 index 20ea57d..0000000 --- a/eigen/blas/single.cpp +++ /dev/null @@ -1,22 +0,0 @@ -// This file is part of Eigen, a lightweight C++ template library -// for linear algebra. -// -// Copyright (C) 2009 Gael Guennebaud <gael.guennebaud@inria.fr> -// -// This Source Code Form is subject to the terms of the Mozilla -// Public License v. 2.0. If a copy of the MPL was not distributed -// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - -#define SCALAR float -#define SCALAR_SUFFIX s -#define SCALAR_SUFFIX_UP "S" -#define ISCOMPLEX 0 - -#include "level1_impl.h" -#include "level1_real_impl.h" -#include "level2_impl.h" -#include "level2_real_impl.h" -#include "level3_impl.h" - -float BLASFUNC(sdsdot)(int* n, float* alpha, float* x, int* incx, float* y, int* incy) -{ return double(*alpha) + BLASFUNC(dsdot)(n, x, incx, y, incy); } diff --git a/eigen/blas/testing/CMakeLists.txt b/eigen/blas/testing/CMakeLists.txt deleted file mode 100644 index 3ab8026..0000000 --- a/eigen/blas/testing/CMakeLists.txt +++ /dev/null @@ -1,40 +0,0 @@ - -macro(ei_add_blas_test testname) - - set(targetname ${testname}) - - set(filename ${testname}.f) - add_executable(${targetname} ${filename}) - - target_link_libraries(${targetname} eigen_blas) - - if(EIGEN_STANDARD_LIBRARIES_TO_LINK_TO) - target_link_libraries(${targetname} ${EIGEN_STANDARD_LIBRARIES_TO_LINK_TO}) - endif() - - target_link_libraries(${targetname} ${EXTERNAL_LIBS}) - - add_test(${testname} "${Eigen_SOURCE_DIR}/blas/testing/runblastest.sh" "${testname}" "${Eigen_SOURCE_DIR}/blas/testing/${testname}.dat") - add_dependencies(buildtests ${targetname}) - -endmacro(ei_add_blas_test) - -ei_add_blas_test(sblat1) -ei_add_blas_test(sblat2) -ei_add_blas_test(sblat3) - -ei_add_blas_test(dblat1) -ei_add_blas_test(dblat2) -ei_add_blas_test(dblat3) - -ei_add_blas_test(cblat1) -ei_add_blas_test(cblat2) -ei_add_blas_test(cblat3) - -ei_add_blas_test(zblat1) -ei_add_blas_test(zblat2) -ei_add_blas_test(zblat3) - -# add_custom_target(level1) -# add_dependencies(level1 sblat1) - diff --git a/eigen/blas/testing/cblat1.f b/eigen/blas/testing/cblat1.f deleted file mode 100644 index 8ca67fb..0000000 --- a/eigen/blas/testing/cblat1.f +++ /dev/null @@ -1,724 +0,0 @@ -*> \brief \b CBLAT1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM CBLAT1 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX Level 1 BLAS. -*> Based upon the original BLAS test routine together with: -*> -*> F06GAF Example Program Text -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex_blas_testing -* -* ===================================================================== - PROGRAM CBLAT1 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - REAL SFAC - INTEGER IC -* .. External Subroutines .. - EXTERNAL CHECK1, CHECK2, HEADER -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA SFAC/9.765625E-4/ -* .. Executable Statements .. - WRITE (NOUT,99999) - DO 20 IC = 1, 10 - ICASE = IC - CALL HEADER -* -* Initialize PASS, INCX, INCY, and MODE for a new case. -* The value 9999 for INCX, INCY or MODE will appear in the -* detailed output, if any, for cases that do not involve -* these parameters. -* - PASS = .TRUE. - INCX = 9999 - INCY = 9999 - MODE = 9999 - IF (ICASE.LE.5) THEN - CALL CHECK2(SFAC) - ELSE IF (ICASE.GE.6) THEN - CALL CHECK1(SFAC) - END IF -* -- Print - IF (PASS) WRITE (NOUT,99998) - 20 CONTINUE - STOP -* -99999 FORMAT (' Complex BLAS Test Program Results',/1X) -99998 FORMAT (' ----- PASS -----') - END - SUBROUTINE HEADER -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Arrays .. - CHARACTER*6 L(10) -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA L(1)/'CDOTC '/ - DATA L(2)/'CDOTU '/ - DATA L(3)/'CAXPY '/ - DATA L(4)/'CCOPY '/ - DATA L(5)/'CSWAP '/ - DATA L(6)/'SCNRM2'/ - DATA L(7)/'SCASUM'/ - DATA L(8)/'CSCAL '/ - DATA L(9)/'CSSCAL'/ - DATA L(10)/'ICAMAX'/ -* .. Executable Statements .. - WRITE (NOUT,99999) ICASE, L(ICASE) - RETURN -* -99999 FORMAT (/' Test of subprogram number',I3,12X,A6) - END - SUBROUTINE CHECK1(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - COMPLEX CA - REAL SA - INTEGER I, J, LEN, NP1 -* .. Local Arrays .. - COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), - + MWPCS(5), MWPCT(5) - REAL STRUE2(5), STRUE4(5) - INTEGER ITRUE3(5) -* .. External Functions .. - REAL SCASUM, SCNRM2 - INTEGER ICAMAX - EXTERNAL SCASUM, SCNRM2, ICAMAX -* .. External Subroutines .. - EXTERNAL CSCAL, CSSCAL, CTEST, ITEST1, STEST1 -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA SA, CA/0.3E0, (0.4E0,-0.7E0)/ - DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (0.3E0,-0.4E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (0.1E0,-0.3E0), (0.5E0,-0.1E0), (5.0E0,6.0E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (0.1E0,0.1E0), - + (-0.6E0,0.1E0), (0.1E0,-0.3E0), (7.0E0,8.0E0), - + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.5E0,0.0E0), - + (0.0E0,0.5E0), (0.0E0,0.2E0), (2.0E0,3.0E0), - + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ - DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (0.3E0,-0.4E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (0.1E0,-0.3E0), (8.0E0,9.0E0), (0.5E0,-0.1E0), - + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (2.0E0,5.0E0), (2.0E0,5.0E0), (0.1E0,0.1E0), - + (3.0E0,6.0E0), (-0.6E0,0.1E0), (4.0E0,7.0E0), - + (0.1E0,-0.3E0), (7.0E0,2.0E0), (7.0E0,2.0E0), - + (7.0E0,2.0E0), (0.3E0,0.1E0), (5.0E0,8.0E0), - + (0.5E0,0.0E0), (6.0E0,9.0E0), (0.0E0,0.5E0), - + (8.0E0,3.0E0), (0.0E0,0.2E0), (9.0E0,4.0E0)/ - DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.8E0/ - DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.6E0/ - DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (-0.16E0,-0.37E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (-0.17E0,-0.19E0), (0.13E0,-0.39E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (0.11E0,-0.03E0), (-0.17E0,0.46E0), - + (-0.17E0,-0.19E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (0.19E0,-0.17E0), (0.20E0,-0.35E0), - + (0.35E0,0.20E0), (0.14E0,0.08E0), - + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0), - + (2.0E0,3.0E0)/ - DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (-0.16E0,-0.37E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (-0.17E0,-0.19E0), (8.0E0,9.0E0), - + (0.13E0,-0.39E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (0.11E0,-0.03E0), (3.0E0,6.0E0), - + (-0.17E0,0.46E0), (4.0E0,7.0E0), - + (-0.17E0,-0.19E0), (7.0E0,2.0E0), (7.0E0,2.0E0), - + (7.0E0,2.0E0), (0.19E0,-0.17E0), (5.0E0,8.0E0), - + (0.20E0,-0.35E0), (6.0E0,9.0E0), - + (0.35E0,0.20E0), (8.0E0,3.0E0), - + (0.14E0,0.08E0), (9.0E0,4.0E0)/ - DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), - + (1.0E0,2.0E0), (0.09E0,-0.12E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), - + (0.03E0,-0.09E0), (0.15E0,-0.03E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), - + (0.03E0,0.03E0), (-0.18E0,0.03E0), - + (0.03E0,-0.09E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), - + (0.09E0,0.03E0), (0.15E0,0.00E0), - + (0.00E0,0.15E0), (0.00E0,0.06E0), (2.0E0,3.0E0), - + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ - DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), - + (4.0E0,5.0E0), (0.09E0,-0.12E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), - + (0.03E0,-0.09E0), (8.0E0,9.0E0), - + (0.15E0,-0.03E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), - + (0.03E0,0.03E0), (3.0E0,6.0E0), - + (-0.18E0,0.03E0), (4.0E0,7.0E0), - + (0.03E0,-0.09E0), (7.0E0,2.0E0), (7.0E0,2.0E0), - + (7.0E0,2.0E0), (0.09E0,0.03E0), (5.0E0,8.0E0), - + (0.15E0,0.00E0), (6.0E0,9.0E0), (0.00E0,0.15E0), - + (8.0E0,3.0E0), (0.00E0,0.06E0), (9.0E0,4.0E0)/ - DATA ITRUE3/0, 1, 2, 2, 2/ -* .. Executable Statements .. - DO 60 INCX = 1, 2 - DO 40 NP1 = 1, 5 - N = NP1 - 1 - LEN = 2*MAX(N,1) -* .. Set vector arguments .. - DO 20 I = 1, LEN - CX(I) = CV(I,NP1,INCX) - 20 CONTINUE - IF (ICASE.EQ.6) THEN -* .. SCNRM2 .. - CALL STEST1(SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1), - + SFAC) - ELSE IF (ICASE.EQ.7) THEN -* .. SCASUM .. - CALL STEST1(SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1), - + SFAC) - ELSE IF (ICASE.EQ.8) THEN -* .. CSCAL .. - CALL CSCAL(N,CA,CX,INCX) - CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), - + SFAC) - ELSE IF (ICASE.EQ.9) THEN -* .. CSSCAL .. - CALL CSSCAL(N,SA,CX,INCX) - CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), - + SFAC) - ELSE IF (ICASE.EQ.10) THEN -* .. ICAMAX .. - CALL ITEST1(ICAMAX(N,CX,INCX),ITRUE3(NP1)) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' - STOP - END IF -* - 40 CONTINUE - 60 CONTINUE -* - INCX = 1 - IF (ICASE.EQ.8) THEN -* CSCAL -* Add a test for alpha equal to zero. - CA = (0.0E0,0.0E0) - DO 80 I = 1, 5 - MWPCT(I) = (0.0E0,0.0E0) - MWPCS(I) = (1.0E0,1.0E0) - 80 CONTINUE - CALL CSCAL(5,CA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) - ELSE IF (ICASE.EQ.9) THEN -* CSSCAL -* Add a test for alpha equal to zero. - SA = 0.0E0 - DO 100 I = 1, 5 - MWPCT(I) = (0.0E0,0.0E0) - MWPCS(I) = (1.0E0,1.0E0) - 100 CONTINUE - CALL CSSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) -* Add a test for alpha equal to one. - SA = 1.0E0 - DO 120 I = 1, 5 - MWPCT(I) = CX(I) - MWPCS(I) = CX(I) - 120 CONTINUE - CALL CSSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) -* Add a test for alpha equal to minus one. - SA = -1.0E0 - DO 140 I = 1, 5 - MWPCT(I) = -CX(I) - MWPCS(I) = -CX(I) - 140 CONTINUE - CALL CSSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) - END IF - RETURN - END - SUBROUTINE CHECK2(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - COMPLEX CA - INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY -* .. Local Arrays .. - COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14), - + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4), - + CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7) - INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) -* .. External Functions .. - COMPLEX CDOTC, CDOTU - EXTERNAL CDOTC, CDOTU -* .. External Subroutines .. - EXTERNAL CAXPY, CCOPY, CSWAP, CTEST -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA CA/(0.4E0,-0.7E0)/ - DATA INCXS/1, 2, -2, -1/ - DATA INCYS/1, -2, 1, -2/ - DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ - DATA NS/0, 1, 2, 4/ - DATA CX1/(0.7E0,-0.8E0), (-0.4E0,-0.7E0), - + (-0.1E0,-0.9E0), (0.2E0,-0.8E0), - + (-0.9E0,-0.4E0), (0.1E0,0.4E0), (-0.6E0,0.6E0)/ - DATA CY1/(0.6E0,-0.6E0), (-0.9E0,0.5E0), - + (0.7E0,-0.6E0), (0.1E0,-0.5E0), (-0.1E0,-0.2E0), - + (-0.5E0,-0.3E0), (0.8E0,-0.7E0)/ - DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.32E0,-1.41E0), - + (-1.55E0,0.5E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (-1.55E0,0.5E0), - + (0.03E0,-0.89E0), (-0.38E0,-0.96E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ - DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.07E0,-0.89E0), - + (-0.9E0,0.5E0), (0.42E0,-1.41E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.78E0,0.06E0), (-0.9E0,0.5E0), - + (0.06E0,-0.13E0), (0.1E0,-0.5E0), - + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), - + (0.52E0,-1.51E0)/ - DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.07E0,-0.89E0), - + (-1.18E0,-0.31E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.78E0,0.06E0), (-1.54E0,0.97E0), - + (0.03E0,-0.89E0), (-0.18E0,-1.31E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ - DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.32E0,-1.41E0), (-0.9E0,0.5E0), - + (0.05E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.32E0,-1.41E0), - + (-0.9E0,0.5E0), (0.05E0,-0.6E0), (0.1E0,-0.5E0), - + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), - + (0.32E0,-1.16E0)/ - DATA CT7/(0.0E0,0.0E0), (-0.06E0,-0.90E0), - + (0.65E0,-0.47E0), (-0.34E0,-1.22E0), - + (0.0E0,0.0E0), (-0.06E0,-0.90E0), - + (-0.59E0,-1.46E0), (-1.04E0,-0.04E0), - + (0.0E0,0.0E0), (-0.06E0,-0.90E0), - + (-0.83E0,0.59E0), (0.07E0,-0.37E0), - + (0.0E0,0.0E0), (-0.06E0,-0.90E0), - + (-0.76E0,-1.15E0), (-1.33E0,-1.82E0)/ - DATA CT6/(0.0E0,0.0E0), (0.90E0,0.06E0), - + (0.91E0,-0.77E0), (1.80E0,-0.10E0), - + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.45E0,0.74E0), - + (0.20E0,0.90E0), (0.0E0,0.0E0), (0.90E0,0.06E0), - + (-0.55E0,0.23E0), (0.83E0,-0.39E0), - + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.04E0,0.79E0), - + (1.95E0,1.22E0)/ - DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.6E0,-0.6E0), (-0.9E0,0.5E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), - + (-0.9E0,0.5E0), (0.7E0,-0.6E0), (0.1E0,-0.5E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ - DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.7E0,-0.6E0), (-0.4E0,-0.7E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.8E0,-0.7E0), - + (-0.4E0,-0.7E0), (-0.1E0,-0.2E0), - + (0.2E0,-0.8E0), (0.7E0,-0.6E0), (0.1E0,0.4E0), - + (0.6E0,-0.6E0)/ - DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.9E0,0.5E0), (-0.4E0,-0.7E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.1E0,-0.5E0), - + (-0.4E0,-0.7E0), (0.7E0,-0.6E0), (0.2E0,-0.8E0), - + (-0.9E0,0.5E0), (0.1E0,0.4E0), (0.6E0,-0.6E0)/ - DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.6E0,-0.6E0), (0.7E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), - + (0.7E0,-0.6E0), (-0.1E0,-0.2E0), (0.8E0,-0.7E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ - DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.4E0,-0.7E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), - + (-0.4E0,-0.7E0), (-0.1E0,-0.9E0), - + (0.2E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0)/ - DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (-0.9E0,0.5E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), - + (-0.9E0,0.5E0), (-0.9E0,-0.4E0), (0.1E0,-0.5E0), - + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), - + (0.7E0,-0.8E0)/ - DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (0.7E0,-0.8E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), - + (-0.9E0,-0.4E0), (-0.1E0,-0.9E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0)/ - DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.9E0,0.5E0), - + (-0.4E0,-0.7E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), - + (-0.9E0,0.5E0), (-0.4E0,-0.7E0), (0.1E0,-0.5E0), - + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), - + (0.2E0,-0.8E0)/ - DATA CSIZE1/(0.0E0,0.0E0), (0.9E0,0.9E0), - + (1.63E0,1.73E0), (2.90E0,2.78E0)/ - DATA CSIZE3/(0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.17E0,1.17E0), - + (1.17E0,1.17E0), (1.17E0,1.17E0), - + (1.17E0,1.17E0), (1.17E0,1.17E0), - + (1.17E0,1.17E0), (1.17E0,1.17E0)/ - DATA CSIZE2/(0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), - + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.54E0,1.54E0), - + (1.54E0,1.54E0), (1.54E0,1.54E0), - + (1.54E0,1.54E0), (1.54E0,1.54E0), - + (1.54E0,1.54E0), (1.54E0,1.54E0)/ -* .. Executable Statements .. - DO 60 KI = 1, 4 - INCX = INCXS(KI) - INCY = INCYS(KI) - MX = ABS(INCX) - MY = ABS(INCY) -* - DO 40 KN = 1, 4 - N = NS(KN) - KSIZE = MIN(2,KN) - LENX = LENS(KN,MX) - LENY = LENS(KN,MY) -* .. initialize all argument arrays .. - DO 20 I = 1, 7 - CX(I) = CX1(I) - CY(I) = CY1(I) - 20 CONTINUE - IF (ICASE.EQ.1) THEN -* .. CDOTC .. - CDOT(1) = CDOTC(N,CX,INCX,CY,INCY) - CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) - ELSE IF (ICASE.EQ.2) THEN -* .. CDOTU .. - CDOT(1) = CDOTU(N,CX,INCX,CY,INCY) - CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) - ELSE IF (ICASE.EQ.3) THEN -* .. CAXPY .. - CALL CAXPY(N,CA,CX,INCX,CY,INCY) - CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) - ELSE IF (ICASE.EQ.4) THEN -* .. CCOPY .. - CALL CCOPY(N,CX,INCX,CY,INCY) - CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) - ELSE IF (ICASE.EQ.5) THEN -* .. CSWAP .. - CALL CSWAP(N,CX,INCX,CY,INCY) - CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0E0) - CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' - STOP - END IF -* - 40 CONTINUE - 60 CONTINUE - RETURN - END - SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) -* ********************************* STEST ************************** -* -* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO -* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE -* NEGLIGIBLE. -* -* C. L. LAWSON, JPL, 1974 DEC 10 -* -* .. Parameters .. - INTEGER NOUT - REAL ZERO - PARAMETER (NOUT=6, ZERO=0.0E0) -* .. Scalar Arguments .. - REAL SFAC - INTEGER LEN -* .. Array Arguments .. - REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - REAL SD - INTEGER I -* .. External Functions .. - REAL SDIFF - EXTERNAL SDIFF -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Executable Statements .. -* - DO 40 I = 1, LEN - SD = SCOMP(I) - STRUE(I) - IF (ABS(SFAC*SD) .LE. ABS(SSIZE(I))*EPSILON(ZERO)) - + GO TO 40 -* -* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). -* - IF ( .NOT. PASS) GO TO 20 -* PRINT FAIL MESSAGE AND HEADER. - PASS = .FALSE. - WRITE (NOUT,99999) - WRITE (NOUT,99998) - 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), - + STRUE(I), SD, SSIZE(I) - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY MODE I ', - + ' COMP(I) TRUE(I) DIFFERENCE', - + ' SIZE(I)',/1X) -99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4) - END - SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) -* ************************* STEST1 ***************************** -* -* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN -* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE -* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. -* -* C.L. LAWSON, JPL, 1978 DEC 6 -* -* .. Scalar Arguments .. - REAL SCOMP1, SFAC, STRUE1 -* .. Array Arguments .. - REAL SSIZE(*) -* .. Local Arrays .. - REAL SCOMP(1), STRUE(1) -* .. External Subroutines .. - EXTERNAL STEST -* .. Executable Statements .. -* - SCOMP(1) = SCOMP1 - STRUE(1) = STRUE1 - CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) -* - RETURN - END - REAL FUNCTION SDIFF(SA,SB) -* ********************************* SDIFF ************************** -* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 -* -* .. Scalar Arguments .. - REAL SA, SB -* .. Executable Statements .. - SDIFF = SA - SB - RETURN - END - SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC) -* **************************** CTEST ***************************** -* -* C.L. LAWSON, JPL, 1978 DEC 6 -* -* .. Scalar Arguments .. - REAL SFAC - INTEGER LEN -* .. Array Arguments .. - COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN) -* .. Local Scalars .. - INTEGER I -* .. Local Arrays .. - REAL SCOMP(20), SSIZE(20), STRUE(20) -* .. External Subroutines .. - EXTERNAL STEST -* .. Intrinsic Functions .. - INTRINSIC AIMAG, REAL -* .. Executable Statements .. - DO 20 I = 1, LEN - SCOMP(2*I-1) = REAL(CCOMP(I)) - SCOMP(2*I) = AIMAG(CCOMP(I)) - STRUE(2*I-1) = REAL(CTRUE(I)) - STRUE(2*I) = AIMAG(CTRUE(I)) - SSIZE(2*I-1) = REAL(CSIZE(I)) - SSIZE(2*I) = AIMAG(CSIZE(I)) - 20 CONTINUE -* - CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC) - RETURN - END - SUBROUTINE ITEST1(ICOMP,ITRUE) -* ********************************* ITEST1 ************************* -* -* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR -* EQUALITY. -* C. L. LAWSON, JPL, 1974 DEC 10 -* -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - INTEGER ICOMP, ITRUE -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER ID -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Executable Statements .. - IF (ICOMP.EQ.ITRUE) GO TO 40 -* -* HERE ICOMP IS NOT EQUAL TO ITRUE. -* - IF ( .NOT. PASS) GO TO 20 -* PRINT FAIL MESSAGE AND HEADER. - PASS = .FALSE. - WRITE (NOUT,99999) - WRITE (NOUT,99998) - 20 ID = ICOMP - ITRUE - WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY MODE ', - + ' COMP TRUE DIFFERENCE', - + /1X) -99997 FORMAT (1X,I4,I3,3I5,2I36,I12) - END diff --git a/eigen/blas/testing/cblat2.dat b/eigen/blas/testing/cblat2.dat deleted file mode 100644 index ae98730..0000000 --- a/eigen/blas/testing/cblat2.dat +++ /dev/null @@ -1,35 +0,0 @@ -'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. diff --git a/eigen/blas/testing/cblat2.f b/eigen/blas/testing/cblat2.f deleted file mode 100644 index 5833ea8..0000000 --- a/eigen/blas/testing/cblat2.f +++ /dev/null @@ -1,3279 +0,0 @@ -*> \brief \b CBLAT2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM CBLAT2 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX Level 2 Blas. -*> -*> The program must be driven by a short data file. The first 18 records -*> of the file are read using list-directed input, the last 17 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 35 lines: -*> 'cblat2.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 4 NUMBER OF VALUES OF K -*> 0 1 2 4 VALUES OF K -*> 4 NUMBER OF VALUES OF INCX AND INCY -*> 1 2 -1 -2 VALUES OF INCX AND INCY -*> 3 NUMBER OF VALUES OF ALPHA -*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -*> CGEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CGBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CHEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CHBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CHPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTRMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTRSV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTBSV T PUT F FOR NO TEST. SAME COLUMNS. -*> CTPSV T PUT F FOR NO TEST. SAME COLUMNS. -*> CGERC T PUT F FOR NO TEST. SAME COLUMNS. -*> CGERU T PUT F FOR NO TEST. SAME COLUMNS. -*> CHER T PUT F FOR NO TEST. SAME COLUMNS. -*> CHPR T PUT F FOR NO TEST. SAME COLUMNS. -*> CHER2 T PUT F FOR NO TEST. SAME COLUMNS. -*> CHPR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. -*> An extended set of Fortran Basic Linear Algebra Subprograms. -*> -*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics -*> and Computer Science Division, Argonne National Laboratory, -*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> Or -*> -*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms -*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford -*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st -*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. -*> -*> -*> -- Written on 10-August-1987. -*> Richard Hanson, Sandia National Labs. -*> Jeremy Du Croz, NAG Central Office. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex_blas_testing -* -* ===================================================================== - PROGRAM CBLAT2 -* -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 17 ) - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) - INTEGER NMAX, INCMAX - PARAMETER ( NMAX = 65, INCMAX = 2 ) - INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX - PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, - $ NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, - $ NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANS - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( 2*NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - REAL SDIFF - LOGICAL LCE - EXTERNAL SDIFF, LCE -* .. External Subroutines .. - EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6, - $ CCHKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'CGEMV ', 'CGBMV ', 'CHEMV ', 'CHBMV ', - $ 'CHPMV ', 'CTRMV ', 'CTBMV ', 'CTPMV ', - $ 'CTRSV ', 'CTBSV ', 'CTPSV ', 'CGERC ', - $ 'CGERU ', 'CHER ', 'CHPR ', 'CHER2 ', - $ 'CHPR2 '/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 230 - END IF - 10 CONTINUE -* Values of K - READ( NIN, FMT = * )NKB - IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN - WRITE( NOUT, FMT = 9997 )'K', NKBMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) - DO 20 I = 1, NKB - IF( KB( I ).LT.0 )THEN - WRITE( NOUT, FMT = 9995 ) - GO TO 230 - END IF - 20 CONTINUE -* Values of INCX and INCY - READ( NIN, FMT = * )NINC - IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN - WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) - DO 30 I = 1, NINC - IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN - WRITE( NOUT, FMT = 9994 )INCMAX - GO TO 230 - END IF - 30 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9993 ) - WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) - WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) - WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9980 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 40 I = 1, NSUBS - LTEST( I ) = .FALSE. - 40 CONTINUE - 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT - DO 60 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 70 - 60 CONTINUE - WRITE( NOUT, FMT = 9986 )SNAMET - STOP - 70 LTEST( I ) = LTESTT - GO TO 50 -* - 80 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(RZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of CMVCH using exact data. -* - N = MIN( 32, NMAX ) - DO 120 J = 1, N - DO 110 I = 1, N - A( I, J ) = MAX( I - J + 1, 0 ) - 110 CONTINUE - X( J ) = J - Y( J ) = ZERO - 120 CONTINUE - DO 130 J = 1, N - YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE -* YY holds the exact result. On exit from CMVCH YT holds -* the result computed by CMVCH. - TRANS = 'N' - CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF - TRANS = 'T' - CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 210 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL CCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 140, 150, 150, 150, 160, 160, - $ 160, 160, 160, 160, 170, 170, 180, - $ 180, 190, 190 )ISNUM -* Test CGEMV, 01, and CGBMV, 02. - 140 CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test CHEMV, 03, CHBMV, 04, and CHPMV, 05. - 150 CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test CTRMV, 06, CTBMV, 07, CTPMV, 08, -* CTRSV, 09, CTBSV, 10, and CTPSV, 11. - 160 CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) - GO TO 200 -* Test CGERC, 12, CGERU, 13. - 170 CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test CHER, 14, and CHPR, 15. - 180 CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test CHER2, 16, and CHPR2, 17. - 190 CALL CCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) -* - 200 IF( FATAL.AND.SFATAL ) - $ GO TO 220 - END IF - 210 CONTINUE - WRITE( NOUT, FMT = 9982 ) - GO TO 240 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9981 ) - GO TO 240 -* - 230 CONTINUE - WRITE( NOUT, FMT = 9987 ) -* - 240 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) - 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', - $ I2 ) - 9993 FORMAT( ' TESTS OF THE COMPLEX LEVEL 2 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9992 FORMAT( ' FOR N ', 9I6 ) - 9991 FORMAT( ' FOR K ', 7I6 ) - 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) - 9989 FORMAT( ' FOR ALPHA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9988 FORMAT( ' FOR BETA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9985 FORMAT( ' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' CMVCH WAS CALLED WITH TRANS = ', A1, - $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / - $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' - $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9982 FORMAT( /' END OF TESTS' ) - 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of CBLAT2. -* - END - SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests CGEMV and CGBMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BLS, TRANSL - REAL ERR, ERRMAX - INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, - $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, - $ NL, NS - LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN - CHARACTER*1 TRANS, TRANSS - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CGBMV, CGEMV, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 11 - ELSE IF( BANDED )THEN - NARGS = 13 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IKU = 1, NK - IF( BANDED )THEN - KU = KB( IKU ) - KL = MAX( KU - 1, 0 ) - ELSE - KU = N - 1 - KL = M - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = KL + KU + 1 - ELSE - LDA = M - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, - $ LDA, KL, KU, RESET, TRANSL ) -* - DO 90 IC = 1, 3 - TRANS = ICH( IC: IC ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' -* - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*NL -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, - $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) - IF( NL.GT.1 )THEN - X( NL/2 ) = ZERO - XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*ML -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL CMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, - $ YY, ABS( INCY ), 0, ML - 1, - $ RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANSS = TRANS - MS = M - NS = N - KLS = KL - KUS = KU - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ TRANS, M, N, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL CGEMV( TRANS, M, N, ALPHA, AA, - $ LDA, XX, INCX, BETA, YY, - $ INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANS, M, N, KL, KU, ALPHA, LDA, - $ INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL CGBMV( TRANS, M, N, KL, KU, ALPHA, - $ AA, LDA, XX, INCX, BETA, - $ YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 130 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANS.EQ.TRANSS - ISAME( 2 ) = MS.EQ.M - ISAME( 3 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LCE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LCE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LCERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 4 ) = KLS.EQ.KL - ISAME( 5 ) = KUS.EQ.KU - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LCE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LCE( XS, XX, LX ) - ISAME( 10 ) = INCXS.EQ.INCX - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 12 ) = LCERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 13 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 130 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL CMVCH( TRANS, M, N, ALPHA, A, - $ NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 130 - ELSE -* Avoid repeating tests with M.le.0 or -* N.le.0. - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 140 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, - $ ALPHA, LDA, INCX, BETA, INCY - END IF -* - 140 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK1. -* - END - SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests CHEMV, CHBMV and CHPMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BLS, TRANSL - REAL ERR, ERRMAX - INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, - $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHBMV, CHEMV, CHPMV, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 10 - ELSE IF( BANDED )THEN - NARGS = 11 - ELSE IF( PACKED )THEN - NARGS = 9 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, - $ LDA, K, K, RESET, TRANSL ) -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - UPLOS = UPLO - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL CHEMV( UPLO, N, ALPHA, AA, LDA, XX, - $ INCX, BETA, YY, INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, N, K, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL CHBMV( UPLO, N, K, ALPHA, AA, LDA, - $ XX, INCX, BETA, YY, INCY ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, N, ALPHA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL CHPMV( UPLO, N, ALPHA, AA, XX, INCX, - $ BETA, YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LCE( AS, AA, LAA ) - ISAME( 5 ) = LDAS.EQ.LDA - ISAME( 6 ) = LCE( XS, XX, LX ) - ISAME( 7 ) = INCXS.EQ.INCX - ISAME( 8 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 9 ) = LCERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 10 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 3 ) = KS.EQ.K - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LCE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LCE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LCERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( PACKED )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LCE( AS, AA, LAA ) - ISAME( 5 ) = LCE( XS, XX, LX ) - ISAME( 6 ) = INCXS.EQ.INCX - ISAME( 7 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 8 ) = LCE( YS, YY, LY ) - ELSE - ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 9 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL CMVCH( 'N', N, N, ALPHA, A, NMAX, X, - $ INCX, BETA, Y, INCY, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0 - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, - $ BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ BETA, INCY - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2, - $ ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ', - $ 'Y,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK2. -* - END - SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) -* -* Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), - $ ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX TRANSL - REAL ERR, ERRMAX - INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, - $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHD, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CMAKE, CMVCH, CTBMV, CTBSV, CTPMV, CTPSV, - $ CTRMV, CTRSV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'R' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 8 - ELSE IF( BANDED )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 7 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* Set up zero vector for CMVCH. - DO 10 I = 1, NMAX - Z( I ) = ZERO - 10 CONTINUE -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) -* - DO 70 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, - $ NMAX, AA, LDA, K, K, RESET, TRANSL ) -* - DO 60 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, - $ TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - DIAGS = DIAG - NS = N - KS = K - DO 20 I = 1, LAA - AS( I ) = AA( I ) - 20 CONTINUE - LDAS = LDA - DO 30 I = 1, LX - XS( I ) = XX( I ) - 30 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTRMV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTBMV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTPMV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTRSV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTBSV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL CTPSV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = TRANS.EQ.TRANSS - ISAME( 3 ) = DIAG.EQ.DIAGS - ISAME( 4 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 5 ) = LCE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 7 ) = LCE( XS, XX, LX ) - ELSE - ISAME( 7 ) = LCERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 8 ) = INCXS.EQ.INCX - ELSE IF( BANDED )THEN - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = LCE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 8 ) = LCE( XS, XX, LX ) - ELSE - ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 9 ) = INCXS.EQ.INCX - ELSE IF( PACKED )THEN - ISAME( 5 ) = LCE( AS, AA, LAA ) - IF( NULL )THEN - ISAME( 6 ) = LCE( XS, XX, LX ) - ELSE - ISAME( 6 ) = LCERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 7 ) = INCXS.EQ.INCX - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MV' )THEN -* -* Check the result. -* - CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, - $ INCX, ZERO, Z, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN -* -* Compute approximation to original vector. -* - DO 50 I = 1, N - Z( I ) = XX( 1 + ( I - 1 )* - $ ABS( INCX ) ) - XX( 1 + ( I - 1 )*ABS( INCX ) ) - $ = X( I ) - 50 CONTINUE - CALL CMVCH( TRANS, N, N, ONE, A, NMAX, Z, - $ INCX, ZERO, X, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .FALSE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0. - GO TO 110 - END IF -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, - $ INCX - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, - $ LDA, INCX - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', - $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), - $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', - $ I3, ', X,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK3. -* - END - SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests CGERC and CGERU. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), - $ ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, TRANSL - REAL ERR, ERRMAX - INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, - $ NC, ND, NS - LOGICAL CONJ, NULL, RESET, SAME -* .. Local Arrays .. - COMPLEX W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CGERC, CGERU, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, CONJG, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. - CONJ = SNAME( 5: 5 ).EQ.'C' -* Define the number of arguments. - NARGS = 9 -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* -* Set LDA to 1 more than minimum value if room. - LDA = M - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 100 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*M -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), - $ 0, M - 1, RESET, TRANSL ) - IF( M.GT.1 )THEN - X( M/2 ) = ZERO - XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO - END IF -* - DO 90 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, - $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, - $ ALPHA, INCX, INCY, LDA - IF( CONJ )THEN - IF( REWI ) - $ REWIND NTRA - CALL CGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) - ELSE - IF( REWI ) - $ REWIND NTRA - CALL CGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 140 - END IF -* -* See what data changed inside subroutine. -* - ISAME( 1 ) = MS.EQ.M - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LCE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LCE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LCE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LCERES( 'GE', ' ', M, N, AS, AA, - $ LDA ) - END IF - ISAME( 9 ) = LDAS.EQ.LDA -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 140 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, M - Z( I ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, M - Z( I ) = X( M - I + 1 ) - 60 CONTINUE - END IF - DO 70 J = 1, N - IF( INCY.GT.0 )THEN - W( 1 ) = Y( J ) - ELSE - W( 1 ) = Y( N - J + 1 ) - END IF - IF( CONJ ) - $ W( 1 ) = CONJG( W( 1 ) ) - CALL CMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, - $ ONE, A( 1, J ), 1, YT, G, - $ AA( 1 + ( J - 1 )*LDA ), EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 130 - 70 CONTINUE - ELSE -* Avoid repeating tests with M.le.0 or N.le.0. - GO TO 110 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 150 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 140 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, - $ '), X,', I2, ', Y,', I2, ', A,', I3, ') ', - $ ' .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK4. -* - END - SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests CHER and CHPR. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), - $ ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX ALPHA, TRANSL - REAL ERR, ERRMAX, RALPHA, RALS - INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, - $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - COMPLEX W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHER, CHPR, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, CMPLX, CONJG, MAX, REAL -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 7 - ELSE IF( PACKED )THEN - NARGS = 6 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IA = 1, NALF - RALPHA = REAL( ALF( IA ) ) - ALPHA = CMPLX( RALPHA, RZERO ) - NULL = N.LE.0.OR.RALPHA.EQ.RZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, - $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - RALS = RALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ RALPHA, INCX, LDA - IF( REWI ) - $ REWIND NTRA - CALL CHER( UPLO, N, RALPHA, XX, INCX, AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ RALPHA, INCX - IF( REWI ) - $ REWIND NTRA - CALL CHPR( UPLO, N, RALPHA, XX, INCX, AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = RALS.EQ.RALPHA - ISAME( 4 ) = LCE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - IF( NULL )THEN - ISAME( 6 ) = LCE( AS, AA, LAA ) - ELSE - ISAME( 6 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, AS, - $ AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 7 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 40 I = 1, N - Z( I ) = X( I ) - 40 CONTINUE - ELSE - DO 50 I = 1, N - Z( I ) = X( N - I + 1 ) - 50 CONTINUE - END IF - JA = 1 - DO 60 J = 1, N - W( 1 ) = CONJG( Z( J ) ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL CMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, - $ 1, ONE, A( JJ, J ), 1, YT, G, - $ AA( JA ), EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 110 - 60 CONTINUE - ELSE -* Avoid repeating tests if N.le.0. - IF( N.LE.0 ) - $ GO TO 100 - END IF -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK5. -* - END - SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests CHER2 and CHPR2. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), - $ ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, TRANSL - REAL ERR, ERRMAX - INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, - $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - COMPLEX W( 2 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHER2, CHPR2, CMAKE, CMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, CONJG, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 8 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 140 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 140 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 130 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 120 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 110 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 100 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, - $ NMAX, AA, LDA, N - 1, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL CHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY - IF( REWI ) - $ REWIND NTRA - CALL CHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 160 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LCE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LCE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LCE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, - $ AS, AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 9 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 160 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, N - Z( I, 1 ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - Z( I, 1 ) = X( N - I + 1 ) - 60 CONTINUE - END IF - IF( INCY.GT.0 )THEN - DO 70 I = 1, N - Z( I, 2 ) = Y( I ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - Z( I, 2 ) = Y( N - I + 1 ) - 80 CONTINUE - END IF - JA = 1 - DO 90 J = 1, N - W( 1 ) = ALPHA*CONJG( Z( J, 2 ) ) - W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL CMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), - $ NMAX, W, 1, ONE, A( JJ, J ), 1, - $ YT, G, AA( JA ), EPS, ERR, FATAL, - $ NOUT, .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 150 - 90 CONTINUE - ELSE -* Avoid repeating tests with N.le.0. - IF( N.LE.0 ) - $ GO TO 140 - END IF -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 170 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 160 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ INCY, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY - END IF -* - 170 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), X,', I2, ', Y,', I2, ', AP) ', - $ ' .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') ', - $ ' .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK6. -* - END - SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 2 Blas. -* Requires a special version of the error-handling routine XERBLA. -* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Local Scalars .. - COMPLEX ALPHA, BETA - REAL RALPHA -* .. Local Arrays .. - COMPLEX A( 1, 1 ), X( 1 ), Y( 1 ) -* .. External Subroutines .. - EXTERNAL CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER, - $ CHER2, CHKXER, CHPMV, CHPR, CHPR2, CTBMV, - $ CTBSV, CTPMV, CTPSV, CTRMV, CTRSV -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90, 100, 110, 120, 130, 140, 150, 160, - $ 170 )ISNUM - 10 INFOT = 1 - CALL CGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 20 INFOT = 1 - CALL CGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 30 INFOT = 1 - CALL CHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 40 INFOT = 1 - CALL CHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 50 INFOT = 1 - CALL CHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 60 INFOT = 1 - CALL CTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 70 INFOT = 1 - CALL CTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 80 INFOT = 1 - CALL CTPMV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTPMV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTPMV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTPMV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTPMV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 90 INFOT = 1 - CALL CTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 100 INFOT = 1 - CALL CTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 110 INFOT = 1 - CALL CTPSV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTPSV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTPSV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTPSV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTPSV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 120 INFOT = 1 - CALL CGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 130 INFOT = 1 - CALL CGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 140 INFOT = 1 - CALL CHER( '/', 0, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHER( 'U', -1, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHER( 'U', 0, RALPHA, X, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER( 'U', 2, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 150 INFOT = 1 - CALL CHPR( '/', 0, RALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHPR( 'U', -1, RALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHPR( 'U', 0, RALPHA, X, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 160 INFOT = 1 - CALL CHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 170 INFOT = 1 - CALL CHPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 180 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of CCHKE. -* - END - SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, - $ KU, RESET, TRANSL ) -* -* Generates values for an M by N matrix A within the bandwidth -* defined by KL and KU. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - COMPLEX ROGUE - PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) - REAL RROGUE - PARAMETER ( RROGUE = -1.0E10 ) -* .. Scalar Arguments .. - COMPLEX TRANSL - INTEGER KL, KU, LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - COMPLEX CBEG - EXTERNAL CBEG -* .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, MAX, MIN, REAL -* .. Executable Statements .. - GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'H' - TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - IF( ( I.LE.J.AND.J - I.LE.KU ).OR. - $ ( I.GE.J.AND.I - J.LE.KL ) )THEN - A( I, J ) = CBEG( RESET ) + TRANSL - ELSE - A( I, J ) = ZERO - END IF - IF( I.NE.J )THEN - IF( SYM )THEN - A( J, I ) = CONJG( A( I, J ) ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( SYM ) - $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'GB' )THEN - DO 90 J = 1, N - DO 60 I1 = 1, KU + 1 - J - AA( I1 + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) - AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) - 70 CONTINUE - DO 80 I3 = I2, LDA - AA( I3 + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN - DO 130 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 100 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 100 CONTINUE - DO 110 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 110 CONTINUE - DO 120 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 120 CONTINUE - IF( SYM )THEN - JJ = J + ( J - 1 )*LDA - AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) - END IF - 130 CONTINUE - ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN - DO 170 J = 1, N - IF( UPPER )THEN - KK = KL + 1 - IBEG = MAX( 1, KL + 2 - J ) - IF( UNIT )THEN - IEND = KL - ELSE - IEND = KL + 1 - END IF - ELSE - KK = 1 - IF( UNIT )THEN - IBEG = 2 - ELSE - IBEG = 1 - END IF - IEND = MIN( KL + 1, 1 + M - J ) - END IF - DO 140 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 140 CONTINUE - DO 150 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) - 150 CONTINUE - DO 160 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 160 CONTINUE - IF( SYM )THEN - JJ = KK + ( J - 1 )*LDA - AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) - END IF - 170 CONTINUE - ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN - IOFF = 0 - DO 190 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 180 I = IBEG, IEND - IOFF = IOFF + 1 - AA( IOFF ) = A( I, J ) - IF( I.EQ.J )THEN - IF( UNIT ) - $ AA( IOFF ) = ROGUE - IF( SYM ) - $ AA( IOFF ) = CMPLX( REAL( AA( IOFF ) ), RROGUE ) - END IF - 180 CONTINUE - 190 CONTINUE - END IF - RETURN -* -* End of CMAKE. -* - END - SUBROUTINE CMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RZERO, RONE - PARAMETER ( RZERO = 0.0, RONE = 1.0 ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - REAL EPS, ERR - INTEGER INCX, INCY, M, N, NMAX, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) - REAL G( * ) -* .. Local Scalars .. - COMPLEX C - REAL ERRI - INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL - LOGICAL CTRAN, TRAN -* .. Intrinsic Functions .. - INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT -* .. Statement Functions .. - REAL ABS1 -* .. Statement Function definitions .. - ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) -* .. Executable Statements .. - TRAN = TRANS.EQ.'T' - CTRAN = TRANS.EQ.'C' - IF( TRAN.OR.CTRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF - IF( INCX.LT.0 )THEN - KX = NL - INCXL = -1 - ELSE - KX = 1 - INCXL = 1 - END IF - IF( INCY.LT.0 )THEN - KY = ML - INCYL = -1 - ELSE - KY = 1 - INCYL = 1 - END IF -* -* Compute expected result in YT using data in A, X and Y. -* Compute gauges in G. -* - IY = KY - DO 40 I = 1, ML - YT( IY ) = ZERO - G( IY ) = RZERO - JX = KX - IF( TRAN )THEN - DO 10 J = 1, NL - YT( IY ) = YT( IY ) + A( J, I )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 10 CONTINUE - ELSE IF( CTRAN )THEN - DO 20 J = 1, NL - YT( IY ) = YT( IY ) + CONJG( A( J, I ) )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 20 CONTINUE - ELSE - DO 30 J = 1, NL - YT( IY ) = YT( IY ) + A( I, J )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 30 CONTINUE - END IF - YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) - G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) - IY = IY + INCYL - 40 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 50 I = 1, ML - ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS - IF( G( I ).NE.RZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.RONE ) - $ GO TO 60 - 50 CONTINUE -* If the loop completes, all results are at least half accurate. - GO TO 80 -* -* Report fatal error. -* - 60 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 70 I = 1, ML - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, YT( I ), - $ YY( 1 + ( I - 1 )*ABS( INCY ) ) - ELSE - WRITE( NOUT, FMT = 9998 )I, - $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) - END IF - 70 CONTINUE -* - 80 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RE', - $ 'SULT COMPUTED RESULT' ) - 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) -* -* End of CMVCH. -* - END - LOGICAL FUNCTION LCE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - COMPLEX RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LCE = .TRUE. - GO TO 30 - 20 CONTINUE - LCE = .FALSE. - 30 RETURN -* -* End of LCE. -* - END - LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE', 'HE' or 'HP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'HE' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LCERES = .TRUE. - GO TO 80 - 70 CONTINUE - LCERES = .FALSE. - 80 RETURN -* -* End of LCERES. -* - END - COMPLEX FUNCTION CBEG( RESET ) -* -* Generates complex numbers as pairs of random numbers uniformly -* distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, J, MI, MJ -* .. Save statement .. - SAVE I, IC, J, MI, MJ -* .. Intrinsic Functions .. - INTRINSIC CMPLX -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - MJ = 457 - I = 7 - J = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I or J is bounded between 1 and 999. -* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. -* If initial I or J = 4 or 8, the period will be 25. -* If initial I or J = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I or J -* in 6. -* - IC = IC + 1 - 10 I = I*MI - J = J*MJ - I = I - 1000*( I/1000 ) - J = J - 1000*( J/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) - RETURN -* -* End of CBEG. -* - END - REAL FUNCTION SDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* -* .. Scalar Arguments .. - REAL X, Y -* .. Executable Statements .. - SDIFF = X - Y - RETURN -* -* End of SDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 2 BLAS -* routines. -* -* XERBLA is an error handler for the Level 2 BLAS routines. -* -* It is called by the Level 2 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/cblat3.dat b/eigen/blas/testing/cblat3.dat deleted file mode 100644 index 59881ea..0000000 --- a/eigen/blas/testing/cblat3.dat +++ /dev/null @@ -1,23 +0,0 @@ -'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. diff --git a/eigen/blas/testing/cblat3.f b/eigen/blas/testing/cblat3.f deleted file mode 100644 index 09f2cb9..0000000 --- a/eigen/blas/testing/cblat3.f +++ /dev/null @@ -1,3492 +0,0 @@ -*> \brief \b CBLAT3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM CBLAT3 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX Level 3 Blas. -*> -*> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 9 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 23 lines: -*> 'cblat3.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 3 NUMBER OF VALUES OF ALPHA -*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -*> CGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> CHEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> CSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> CTRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> CTRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> CHERK T PUT F FOR NO TEST. SAME COLUMNS. -*> CSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> CHER2K T PUT F FOR NO TEST. SAME COLUMNS. -*> CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. -*> A Set of Level 3 Basic Linear Algebra Subprograms. -*> -*> Technical Memorandum No.88 (Revision 1), Mathematics and -*> Computer Science Division, Argonne National Laboratory, 9700 -*> South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex_blas_testing -* -* ===================================================================== - PROGRAM CBLAT3 -* -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 9 ) - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) - INTEGER NMAX - PARAMETER ( NMAX = 65 ) - INTEGER NIDMAX, NALMAX, NBEMAX - PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), - $ BB( NMAX*NMAX ), BET( NBEMAX ), - $ BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ W( 2*NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - REAL SDIFF - LOGICAL LCE - EXTERNAL SDIFF, LCE -* .. External Subroutines .. - EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHKE, CMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'CGEMM ', 'CHEMM ', 'CSYMM ', 'CTRMM ', - $ 'CTRSM ', 'CHERK ', 'CSYRK ', 'CHER2K', - $ 'CSYR2K'/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 220 - END IF - 10 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9984 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 20 I = 1, NSUBS - LTEST( I ) = .FALSE. - 20 CONTINUE - 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT - DO 40 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 50 - 40 CONTINUE - WRITE( NOUT, FMT = 9990 )SNAMET - STOP - 50 LTEST( I ) = LTESTT - GO TO 30 -* - 60 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(RZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of CMMCH using exact data. -* - N = MIN( 32, NMAX ) - DO 100 J = 1, N - DO 90 I = 1, N - AB( I, J ) = MAX( I - J + 1, 0 ) - 90 CONTINUE - AB( J, NMAX + 1 ) = J - AB( 1, NMAX + J ) = J - C( J, 1 ) = ZERO - 100 CONTINUE - DO 110 J = 1, N - CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 110 CONTINUE -* CC holds the exact result. On exit from CMMCH CT holds -* the result computed by CMMCH. - TRANSA = 'N' - TRANSB = 'N' - CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'C' - CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - DO 120 J = 1, N - AB( J, NMAX + 1 ) = N - J + 1 - AB( 1, NMAX + J ) = N - J + 1 - 120 CONTINUE - DO 130 J = 1, N - CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - - $ ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE - TRANSA = 'C' - TRANSB = 'N' - CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'C' - CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LCE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 200 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL CCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 150, 150, 160, 160, 170, 170, - $ 180, 180 )ISNUM -* Test CGEMM, 01. - 140 CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test CHEMM, 02, CSYMM, 03. - 150 CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test CTRMM, 04, CTRSM, 05. - 160 CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, - $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) - GO TO 190 -* Test CHERK, 06, CSYRK, 07. - 170 CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test CHER2K, 08, CSYR2K, 09. - 180 CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) - GO TO 190 -* - 190 IF( FATAL.AND.SFATAL ) - $ GO TO 210 - END IF - 200 CONTINUE - WRITE( NOUT, FMT = 9986 ) - GO TO 230 -* - 210 CONTINUE - WRITE( NOUT, FMT = 9985 ) - GO TO 230 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9991 ) -* - 230 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' TESTS OF THE COMPLEX LEVEL 3 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9994 FORMAT( ' FOR N ', 9I6 ) - 9993 FORMAT( ' FOR ALPHA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9992 FORMAT( ' FOR BETA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9989 FORMAT( ' ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1, - $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', - $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', - $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', - $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9986 FORMAT( /' END OF TESTS' ) - 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of CBLAT3. -* - END - SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests CGEMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BLS - REAL ERR, ERRMAX - INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, - $ MA, MB, MS, N, NA, NARGS, NB, NC, NS - LOGICAL NULL, RESET, SAME, TRANA, TRANB - CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CGEMM, CMAKE, CMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. -* - NARGS = 13 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 110 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICA = 1, 3 - TRANSA = ICH( ICA: ICA ) - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' -* - IF( TRANA )THEN - MA = K - NA = M - ELSE - MA = M - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL CMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICB = 1, 3 - TRANSB = ICH( ICB: ICB ) - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* - IF( TRANB )THEN - MB = N - NB = K - ELSE - MB = K - NB = N - END IF -* Set LDB to 1 more than minimum value if room. - LDB = MB - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 70 - LBB = LDB*NB -* -* Generate the matrix B. -* - CALL CMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, - $ LDB, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL CMAKE( 'GE', ' ', ' ', M, N, C, NMAX, - $ CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANAS = TRANSA - TRANBS = TRANSB - MS = M - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, - $ BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CGEMM( TRANSA, TRANSB, M, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANSA.EQ.TRANAS - ISAME( 2 ) = TRANSB.EQ.TRANBS - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LCE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LCE( BS, BB, LBB ) - ISAME( 10 ) = LDBS.EQ.LDB - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LCE( CS, CC, LCC ) - ELSE - ISAME( 12 ) = LCERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 13 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL CMMCH( TRANSA, TRANSB, M, N, K, - $ ALPHA, A, NMAX, B, NMAX, BETA, - $ C, NMAX, CT, G, CC, LDC, EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, - $ ALPHA, LDA, LDB, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', - $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, - $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK1. -* - END - SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests CHEMM and CSYMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BLS - REAL ERR, ERRMAX - INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, - $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, - $ NARGS, NC, NS - LOGICAL CONJ, LEFT, NULL, RESET, SAME - CHARACTER*1 SIDE, SIDES, UPLO, UPLOS - CHARACTER*2 ICHS, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHEMM, CMAKE, CMMCH, CSYMM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHS/'LR'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 90 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 90 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 90 - LBB = LDB*N -* -* Generate the matrix B. -* - CALL CMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, - $ ZERO ) -* - DO 80 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' -* - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* -* Generate the hermitian or symmetric matrix A. -* - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX, - $ AA, LDA, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL CMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, - $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - IF( CONJ )THEN - CALL CHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) - ELSE - CALL CSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 110 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LCE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LCE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LCE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LCERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 110 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL CMMCH( 'N', 'N', M, N, M, ALPHA, A, - $ NMAX, B, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL CMMCH( 'N', 'N', M, N, N, ALPHA, B, - $ NMAX, A, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 120 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC -* - 120 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, - $ ',', F4.1, '), C,', I3, ') .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK2. -* - END - SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, - $ B, BB, BS, CT, G, C ) -* -* Tests CTRMM and CTRSM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CT( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS - REAL ERR, ERRMAX - INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, - $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, - $ NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, - $ UPLOS - CHARACTER*2 ICHD, ICHS, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CMAKE, CMMCH, CTRMM, CTRSM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ -* .. Executable Statements .. -* - NARGS = 11 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* Set up zero matrix for CMMCH. - DO 20 J = 1, NMAX - DO 10 I = 1, NMAX - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* - DO 140 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 130 - LBB = LDB*N - NULL = M.LE.0.OR.N.LE.0 -* - DO 120 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 130 - LAA = LDA*NA -* - DO 110 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 100 ICT = 1, 3 - TRANSA = ICHT( ICT: ICT ) -* - DO 90 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - CALL CMAKE( 'TR', UPLO, DIAG, NA, NA, A, - $ NMAX, AA, LDA, RESET, ZERO ) -* -* Generate the matrix B. -* - CALL CMAKE( 'GE', ' ', ' ', M, N, B, NMAX, - $ BB, LDB, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - TRANAS = TRANSA - DIAGS = DIAG - MS = M - NS = N - ALS = ALPHA - DO 30 I = 1, LAA - AS( I ) = AA( I ) - 30 CONTINUE - LDAS = LDA - DO 40 I = 1, LBB - BS( I ) = BB( I ) - 40 CONTINUE - LDBS = LDB -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL CTRMM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL CTRSM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = TRANAS.EQ.TRANSA - ISAME( 4 ) = DIAGS.EQ.DIAG - ISAME( 5 ) = MS.EQ.M - ISAME( 6 ) = NS.EQ.N - ISAME( 7 ) = ALS.EQ.ALPHA - ISAME( 8 ) = LCE( AS, AA, LAA ) - ISAME( 9 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 10 ) = LCE( BS, BB, LBB ) - ELSE - ISAME( 10 ) = LCERES( 'GE', ' ', M, N, BS, - $ BB, LDB ) - END IF - ISAME( 11 ) = LDBS.EQ.LDB -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 50 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 50 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MM' )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL CMMCH( TRANSA, 'N', M, N, M, - $ ALPHA, A, NMAX, B, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL CMMCH( 'N', TRANSA, M, N, N, - $ ALPHA, B, NMAX, A, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN -* -* Compute approximation to original -* matrix. -* - DO 70 J = 1, N - DO 60 I = 1, M - C( I, J ) = BB( I + ( J - 1 )* - $ LDB ) - BB( I + ( J - 1 )*LDB ) = ALPHA* - $ B( I, J ) - 60 CONTINUE - 70 CONTINUE -* - IF( LEFT )THEN - CALL CMMCH( TRANSA, 'N', M, N, M, - $ ONE, A, NMAX, C, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - ELSE - CALL CMMCH( 'N', TRANSA, M, N, N, - $ ONE, C, NMAX, A, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - END IF - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 150 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, LDA, LDB -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', - $ ' .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK3. -* - END - SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests CHERK and CSYRK. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RONE, RZERO - PARAMETER ( RONE = 1.0, RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BETS - REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, - $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, - $ NARGS, NC, NS - LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS - CHARACTER*2 ICHT, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHERK, CMAKE, CMMCH, CSYRK -* .. Intrinsic Functions .. - INTRINSIC CMPLX, MAX, REAL -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NC'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 10 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICT = 1, 2 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'C' - IF( TRAN.AND..NOT.CONJ ) - $ TRANS = 'T' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL CMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) - IF( CONJ )THEN - RALPHA = REAL( ALPHA ) - ALPHA = CMPLX( RALPHA, RZERO ) - END IF -* - DO 50 IB = 1, NBET - BETA = BET( IB ) - IF( CONJ )THEN - RBETA = REAL( BETA ) - BETA = CMPLX( RBETA, RZERO ) - END IF - NULL = N.LE.0 - IF( CONJ ) - $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. - $ RZERO ).AND.RBETA.EQ.RONE ) -* -* Generate the matrix C. -* - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, - $ NMAX, CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - IF( CONJ )THEN - RALS = RALPHA - ELSE - ALS = ALPHA - END IF - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - IF( CONJ )THEN - RBETS = RBETA - ELSE - BETS = BETA - END IF - DO 20 I = 1, LCC - CS( I ) = CC( I ) - 20 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( CONJ )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, RALPHA, LDA, RBETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CHERK( UPLO, TRANS, N, K, RALPHA, AA, - $ LDA, RBETA, CC, LDC ) - ELSE - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CSYRK( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - IF( CONJ )THEN - ISAME( 5 ) = RALS.EQ.RALPHA - ELSE - ISAME( 5 ) = ALS.EQ.ALPHA - END IF - ISAME( 6 ) = LCE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( CONJ )THEN - ISAME( 8 ) = RBETS.EQ.RBETA - ELSE - ISAME( 8 ) = BETS.EQ.BETA - END IF - IF( NULL )THEN - ISAME( 9 ) = LCE( CS, CC, LCC ) - ELSE - ISAME( 9 ) = LCERES( SNAME( 2: 3 ), UPLO, N, - $ N, CS, CC, LDC ) - END IF - ISAME( 10 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( CONJ )THEN - TRANST = 'C' - ELSE - TRANST = 'T' - END IF - JC = 1 - DO 40 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - CALL CMMCH( TRANST, 'N', LJ, 1, K, - $ ALPHA, A( 1, JJ ), NMAX, - $ A( 1, J ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL CMMCH( 'N', TRANST, LJ, 1, K, - $ ALPHA, A( JJ, 1 ), NMAX, - $ A( J, 1 ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - 40 CONTINUE - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( CONJ )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, RALPHA, - $ LDA, RBETA, LDC - ELSE - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, BETA, LDC - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, - $ '), C,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK4. -* - END - SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) -* -* Tests CHER2K and CSYR2K. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - REAL RONE, RZERO - PARAMETER ( RONE = 1.0, RZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), - $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), - $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ W( 2*NMAX ) - REAL G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX ALPHA, ALS, BETA, BETS - REAL ERR, ERRMAX, RBETA, RBETS - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, - $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, - $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS - CHARACTER*2 ICHT, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LCE, LCERES - EXTERNAL LCE, LCERES -* .. External Subroutines .. - EXTERNAL CHER2K, CMAKE, CMMCH, CSYR2K -* .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, MAX, REAL -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NC'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 130 - LCC = LDC*N -* - DO 120 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 110 ICT = 1, 2 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'C' - IF( TRAN.AND..NOT.CONJ ) - $ TRANS = 'T' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*NA -* -* Generate the matrix A. -* - IF( TRAN )THEN - CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, - $ LDA, RESET, ZERO ) - ELSE - CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, - $ RESET, ZERO ) - END IF -* -* Generate the matrix B. -* - LDB = LDA - LBB = LAA - IF( TRAN )THEN - CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), - $ 2*NMAX, BB, LDB, RESET, ZERO ) - ELSE - CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), - $ NMAX, BB, LDB, RESET, ZERO ) - END IF -* - DO 100 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 90 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 80 IB = 1, NBET - BETA = BET( IB ) - IF( CONJ )THEN - RBETA = REAL( BETA ) - BETA = CMPLX( RBETA, RZERO ) - END IF - NULL = N.LE.0 - IF( CONJ ) - $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. - $ ZERO ).AND.RBETA.EQ.RONE ) -* -* Generate the matrix C. -* - CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, - $ NMAX, CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - IF( CONJ )THEN - RBETS = RBETA - ELSE - BETS = BETA - END IF - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( CONJ )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, RBETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CHER2K( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BB, LDB, RBETA, CC, LDC ) - ELSE - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL CSYR2K( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BB, LDB, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LCE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LCE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - IF( CONJ )THEN - ISAME( 10 ) = RBETS.EQ.RBETA - ELSE - ISAME( 10 ) = BETS.EQ.BETA - END IF - IF( NULL )THEN - ISAME( 11 ) = LCE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LCERES( 'HE', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( CONJ )THEN - TRANST = 'C' - ELSE - TRANST = 'T' - END IF - JJAB = 1 - JC = 1 - DO 70 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - DO 50 I = 1, K - W( I ) = ALPHA*AB( ( J - 1 )*2* - $ NMAX + K + I ) - IF( CONJ )THEN - W( K + I ) = CONJG( ALPHA )* - $ AB( ( J - 1 )*2* - $ NMAX + I ) - ELSE - W( K + I ) = ALPHA* - $ AB( ( J - 1 )*2* - $ NMAX + I ) - END IF - 50 CONTINUE - CALL CMMCH( TRANST, 'N', LJ, 1, 2*K, - $ ONE, AB( JJAB ), 2*NMAX, W, - $ 2*NMAX, BETA, C( JJ, J ), - $ NMAX, CT, G, CC( JC ), LDC, - $ EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE - DO 60 I = 1, K - IF( CONJ )THEN - W( I ) = ALPHA*CONJG( AB( ( K + - $ I - 1 )*NMAX + J ) ) - W( K + I ) = CONJG( ALPHA* - $ AB( ( I - 1 )*NMAX + - $ J ) ) - ELSE - W( I ) = ALPHA*AB( ( K + I - 1 )* - $ NMAX + J ) - W( K + I ) = ALPHA* - $ AB( ( I - 1 )*NMAX + - $ J ) - END IF - 60 CONTINUE - CALL CMMCH( 'N', 'N', LJ, 1, 2*K, ONE, - $ AB( JJ ), NMAX, W, 2*NMAX, - $ BETA, C( JJ, J ), NMAX, CT, - $ G, CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - IF( TRAN ) - $ JJAB = JJAB + 2*NMAX - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 140 - 70 CONTINUE - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( CONJ )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, RBETA, LDC - ELSE - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, BETA, LDC - END IF -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, - $ ', C,', I3, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, - $ ',', F4.1, '), C,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of CCHK5. -* - END - SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 3 Blas. -* Requires a special version of the error-handling routine XERBLA. -* A, B and C should not need to be defined. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca) -* 3-19-92: Fix argument 12 in calls to CSYMM and CHEMM -* with INFOT = 9 (eca) -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Parameters .. - REAL ONE, TWO - PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 ) -* .. Local Scalars .. - COMPLEX ALPHA, BETA - REAL RALPHA, RBETA -* .. Local Arrays .. - COMPLEX A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) -* .. External Subroutines .. - EXTERNAL CGEMM, CHEMM, CHER2K, CHERK, CHKXER, CSYMM, - $ CSYR2K, CSYRK, CTRMM, CTRSM -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. -* -* Initialize ALPHA, BETA, RALPHA, and RBETA. -* - ALPHA = CMPLX( ONE, -ONE ) - BETA = CMPLX( TWO, -TWO ) - RALPHA = ONE - RBETA = TWO -* - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90 )ISNUM - 10 INFOT = 1 - CALL CGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL CGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL CGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL CGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 20 INFOT = 1 - CALL CHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 30 INFOT = 1 - CALL CSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 40 INFOT = 1 - CALL CTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 50 INFOT = 1 - CALL CTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL CTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL CTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 60 INFOT = 1 - CALL CHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 70 INFOT = 1 - CALL CSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL CSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 80 INFOT = 1 - CALL CHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 90 INFOT = 1 - CALL CSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL CSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL CSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 100 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of CCHKE. -* - END - SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, - $ TRANSL ) -* -* Generates values for an M by N matrix A. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'HE', 'SY' or 'TR'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) - COMPLEX ROGUE - PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) - REAL RZERO - PARAMETER ( RZERO = 0.0 ) - REAL RROGUE - PARAMETER ( RROGUE = -1.0E10 ) -* .. Scalar Arguments .. - COMPLEX TRANSL - INTEGER LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J, JJ - LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - COMPLEX CBEG - EXTERNAL CBEG -* .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, REAL -* .. Executable Statements .. - GEN = TYPE.EQ.'GE' - HER = TYPE.EQ.'HE' - SYM = TYPE.EQ.'SY' - TRI = TYPE.EQ.'TR' - UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - A( I, J ) = CBEG( RESET ) + TRANSL - IF( I.NE.J )THEN -* Set some elements to zero - IF( N.GT.3.AND.J.EQ.N/2 ) - $ A( I, J ) = ZERO - IF( HER )THEN - A( J, I ) = CONJG( A( I, J ) ) - ELSE IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( HER ) - $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 90 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 60 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 70 CONTINUE - DO 80 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - IF( HER )THEN - JJ = J + ( J - 1 )*LDA - AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) - END IF - 90 CONTINUE - END IF - RETURN -* -* End of CMAKE. -* - END - SUBROUTINE CMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, - $ NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0, 0.0 ) ) - REAL RZERO, RONE - PARAMETER ( RZERO = 0.0, RONE = 1.0 ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - REAL EPS, ERR - INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANSA, TRANSB -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ CC( LDCC, * ), CT( * ) - REAL G( * ) -* .. Local Scalars .. - COMPLEX CL - REAL ERRI - INTEGER I, J, K - LOGICAL CTRANA, CTRANB, TRANA, TRANB -* .. Intrinsic Functions .. - INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT -* .. Statement Functions .. - REAL ABS1 -* .. Statement Function definitions .. - ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) ) -* .. Executable Statements .. - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' - CTRANA = TRANSA.EQ.'C' - CTRANB = TRANSB.EQ.'C' -* -* Compute expected result, one column at a time, in CT using data -* in A, B and C. -* Compute gauges in G. -* - DO 220 J = 1, N -* - DO 10 I = 1, M - CT( I ) = ZERO - G( I ) = RZERO - 10 CONTINUE - IF( .NOT.TRANA.AND..NOT.TRANB )THEN - DO 30 K = 1, KK - DO 20 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( K, J ) - G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( TRANA.AND..NOT.TRANB )THEN - IF( CTRANA )THEN - DO 50 K = 1, KK - DO 40 I = 1, M - CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( K, J ) ) - 40 CONTINUE - 50 CONTINUE - ELSE - DO 70 K = 1, KK - DO 60 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( K, J ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( K, J ) ) - 60 CONTINUE - 70 CONTINUE - END IF - ELSE IF( .NOT.TRANA.AND.TRANB )THEN - IF( CTRANB )THEN - DO 90 K = 1, KK - DO 80 I = 1, M - CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( I, K ) )* - $ ABS1( B( J, K ) ) - 80 CONTINUE - 90 CONTINUE - ELSE - DO 110 K = 1, KK - DO 100 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( J, K ) - G( I ) = G( I ) + ABS1( A( I, K ) )* - $ ABS1( B( J, K ) ) - 100 CONTINUE - 110 CONTINUE - END IF - ELSE IF( TRANA.AND.TRANB )THEN - IF( CTRANA )THEN - IF( CTRANB )THEN - DO 130 K = 1, KK - DO 120 I = 1, M - CT( I ) = CT( I ) + CONJG( A( K, I ) )* - $ CONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 120 CONTINUE - 130 CONTINUE - ELSE - DO 150 K = 1, KK - DO 140 I = 1, M - CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE - IF( CTRANB )THEN - DO 170 K = 1, KK - DO 160 I = 1, M - CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 190 K = 1, KK - DO 180 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( J, K ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 180 CONTINUE - 190 CONTINUE - END IF - END IF - END IF - DO 200 I = 1, M - CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) - G( I ) = ABS1( ALPHA )*G( I ) + - $ ABS1( BETA )*ABS1( C( I, J ) ) - 200 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 210 I = 1, M - ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS - IF( G( I ).NE.RZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.RONE ) - $ GO TO 230 - 210 CONTINUE -* - 220 CONTINUE -* -* If the loop completes, all results are at least half accurate. - GO TO 250 -* -* Report fatal error. -* - 230 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 240 I = 1, M - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) - ELSE - WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) - END IF - 240 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9997 )J -* - 250 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RE', - $ 'SULT COMPUTED RESULT' ) - 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) - 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) -* -* End of CMMCH. -* - END - LOGICAL FUNCTION LCE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - COMPLEX RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LCE = .TRUE. - GO TO 30 - 20 CONTINUE - LCE = .FALSE. - 30 RETURN -* -* End of LCE. -* - END - LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE' or 'HE' or 'SY'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LCERES = .TRUE. - GO TO 80 - 70 CONTINUE - LCERES = .FALSE. - 80 RETURN -* -* End of LCERES. -* - END - COMPLEX FUNCTION CBEG( RESET ) -* -* Generates complex numbers as pairs of random numbers uniformly -* distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, J, MI, MJ -* .. Save statement .. - SAVE I, IC, J, MI, MJ -* .. Intrinsic Functions .. - INTRINSIC CMPLX -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - MJ = 457 - I = 7 - J = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I or J is bounded between 1 and 999. -* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. -* If initial I or J = 4 or 8, the period will be 25. -* If initial I or J = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I or J -* in 6. -* - IC = IC + 1 - 10 I = I*MI - J = J*MJ - I = I - 1000*( I/1000 ) - J = J - 1000*( J/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) - RETURN -* -* End of CBEG. -* - END - REAL FUNCTION SDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - REAL X, Y -* .. Executable Statements .. - SDIFF = X - Y - RETURN -* -* End of SDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 3 BLAS -* routines. -* -* XERBLA is an error handler for the Level 3 BLAS routines. -* -* It is called by the Level 3 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/dblat1.f b/eigen/blas/testing/dblat1.f deleted file mode 100644 index 30691f9..0000000 --- a/eigen/blas/testing/dblat1.f +++ /dev/null @@ -1,1065 +0,0 @@ -*> \brief \b DBLAT1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM DBLAT1 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the DOUBLE PRECISION Level 1 BLAS. -*> -*> Based upon the original BLAS test routine together with: -*> F06EAF 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 double_blas_testing -* -* ===================================================================== - PROGRAM DBLAT1 -* -* -- 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, N - LOGICAL PASS -* .. Local Scalars .. - DOUBLE PRECISION SFAC - INTEGER IC -* .. External Subroutines .. - EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA SFAC/9.765625D-4/ -* .. Executable Statements .. - WRITE (NOUT,99999) - DO 20 IC = 1, 13 - ICASE = IC - CALL HEADER -* -* .. Initialize PASS, INCX, and INCY for a new case. .. -* .. the value 9999 for INCX or INCY will appear in the .. -* .. detailed output, if any, for cases that do not involve .. -* .. these parameters .. -* - PASS = .TRUE. - INCX = 9999 - INCY = 9999 - IF (ICASE.EQ.3 .OR. ICASE.EQ.11) THEN - CALL CHECK0(SFAC) - ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR. - + ICASE.EQ.10) THEN - CALL CHECK1(SFAC) - ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. - + ICASE.EQ.6 .OR. ICASE.EQ.12 .OR. ICASE.EQ.13) THEN - CALL CHECK2(SFAC) - ELSE IF (ICASE.EQ.4) THEN - CALL CHECK3(SFAC) - END IF -* -- Print - IF (PASS) WRITE (NOUT,99998) - 20 CONTINUE - STOP -* -99999 FORMAT (' Real BLAS Test Program Results',/1X) -99998 FORMAT (' ----- PASS -----') - END - SUBROUTINE HEADER -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Arrays .. - CHARACTER*6 L(13) -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA L(1)/' DDOT '/ - DATA L(2)/'DAXPY '/ - DATA L(3)/'DROTG '/ - DATA L(4)/' DROT '/ - DATA L(5)/'DCOPY '/ - DATA L(6)/'DSWAP '/ - DATA L(7)/'DNRM2 '/ - DATA L(8)/'DASUM '/ - DATA L(9)/'DSCAL '/ - DATA L(10)/'IDAMAX'/ - DATA L(11)/'DROTMG'/ - DATA L(12)/'DROTM '/ - DATA L(13)/'DSDOT '/ -* .. Executable Statements .. - WRITE (NOUT,99999) ICASE, L(ICASE) - RETURN -* -99999 FORMAT (/' Test of subprogram number',I3,12X,A6) - END - SUBROUTINE CHECK0(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - DOUBLE PRECISION SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - DOUBLE PRECISION SA, SB, SC, SS, D12 - INTEGER I, K -* .. Local Arrays .. - DOUBLE PRECISION DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8), - $ DS1(8), DAB(4,9), DTEMP(9), DTRUE(9,9) -* .. External Subroutines .. - EXTERNAL DROTG, DROTMG, STEST1 -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA DA1/0.3D0, 0.4D0, -0.3D0, -0.4D0, -0.3D0, 0.0D0, - + 0.0D0, 1.0D0/ - DATA DB1/0.4D0, 0.3D0, 0.4D0, 0.3D0, -0.4D0, 0.0D0, - + 1.0D0, 0.0D0/ - DATA DC1/0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.6D0, 1.0D0, - + 0.0D0, 1.0D0/ - DATA DS1/0.8D0, 0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.0D0, - + 1.0D0, 0.0D0/ - DATA DATRUE/0.5D0, 0.5D0, 0.5D0, -0.5D0, -0.5D0, - + 0.0D0, 1.0D0, 1.0D0/ - DATA DBTRUE/0.0D0, 0.6D0, 0.0D0, -0.6D0, 0.0D0, - + 0.0D0, 1.0D0, 0.0D0/ -* INPUT FOR MODIFIED GIVENS - DATA DAB/ .1D0,.3D0,1.2D0,.2D0, - A .7D0, .2D0, .6D0, 4.2D0, - B 0.D0,0.D0,0.D0,0.D0, - C 4.D0, -1.D0, 2.D0, 4.D0, - D 6.D-10, 2.D-2, 1.D5, 10.D0, - E 4.D10, 2.D-2, 1.D-5, 10.D0, - F 2.D-10, 4.D-2, 1.D5, 10.D0, - G 2.D10, 4.D-2, 1.D-5, 10.D0, - H 4.D0, -2.D0, 8.D0, 4.D0 / -* TRUE RESULTS FOR MODIFIED GIVENS - DATA DTRUE/0.D0,0.D0, 1.3D0, .2D0, 0.D0,0.D0,0.D0, .5D0, 0.D0, - A 0.D0,0.D0, 4.5D0, 4.2D0, 1.D0, .5D0, 0.D0,0.D0,0.D0, - B 0.D0,0.D0,0.D0,0.D0, -2.D0, 0.D0,0.D0,0.D0,0.D0, - C 0.D0,0.D0,0.D0, 4.D0, -1.D0, 0.D0,0.D0,0.D0,0.D0, - D 0.D0, 15.D-3, 0.D0, 10.D0, -1.D0, 0.D0, -1.D-4, - E 0.D0, 1.D0, - F 0.D0,0.D0, 6144.D-5, 10.D0, -1.D0, 4096.D0, -1.D6, - G 0.D0, 1.D0, - H 0.D0,0.D0,15.D0,10.D0,-1.D0, 5.D-5, 0.D0,1.D0,0.D0, - I 0.D0,0.D0, 15.D0, 10.D0, -1. D0, 5.D5, -4096.D0, - J 1.D0, 4096.D-6, - K 0.D0,0.D0, 7.D0, 4.D0, 0.D0,0.D0, -.5D0, -.25D0, 0.D0/ -* 4096 = 2 ** 12 - DATA D12 /4096.D0/ - DTRUE(1,1) = 12.D0 / 130.D0 - DTRUE(2,1) = 36.D0 / 130.D0 - DTRUE(7,1) = -1.D0 / 6.D0 - DTRUE(1,2) = 14.D0 / 75.D0 - DTRUE(2,2) = 49.D0 / 75.D0 - DTRUE(9,2) = 1.D0 / 7.D0 - DTRUE(1,5) = 45.D-11 * (D12 * D12) - DTRUE(3,5) = 4.D5 / (3.D0 * D12) - DTRUE(6,5) = 1.D0 / D12 - DTRUE(8,5) = 1.D4 / (3.D0 * D12) - DTRUE(1,6) = 4.D10 / (1.5D0 * D12 * D12) - DTRUE(2,6) = 2.D-2 / 1.5D0 - DTRUE(8,6) = 5.D-7 * D12 - DTRUE(1,7) = 4.D0 / 150.D0 - DTRUE(2,7) = (2.D-10 / 1.5D0) * (D12 * D12) - DTRUE(7,7) = -DTRUE(6,5) - DTRUE(9,7) = 1.D4 / D12 - DTRUE(1,8) = DTRUE(1,7) - DTRUE(2,8) = 2.D10 / (1.5D0 * D12 * D12) - DTRUE(1,9) = 32.D0 / 7.D0 - DTRUE(2,9) = -16.D0 / 7.D0 -* .. Executable Statements .. -* -* Compute true values which cannot be prestored -* in decimal notation -* - DBTRUE(1) = 1.0D0/0.6D0 - DBTRUE(3) = -1.0D0/0.6D0 - DBTRUE(5) = 1.0D0/0.6D0 -* - DO 20 K = 1, 8 -* .. Set N=K for identification in output if any .. - N = K - IF (ICASE.EQ.3) THEN -* .. DROTG .. - IF (K.GT.8) GO TO 40 - SA = DA1(K) - SB = DB1(K) - CALL DROTG(SA,SB,SC,SS) - CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC) - CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC) - CALL STEST1(SC,DC1(K),DC1(K),SFAC) - CALL STEST1(SS,DS1(K),DS1(K),SFAC) - ELSEIF (ICASE.EQ.11) THEN -* .. DROTMG .. - DO I=1,4 - DTEMP(I)= DAB(I,K) - DTEMP(I+4) = 0.0 - END DO - DTEMP(9) = 0.0 - CALL DROTMG(DTEMP(1),DTEMP(2),DTEMP(3),DTEMP(4),DTEMP(5)) - CALL STEST(9,DTEMP,DTRUE(1,K),DTRUE(1,K),SFAC) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK0' - STOP - END IF - 20 CONTINUE - 40 RETURN - END - SUBROUTINE CHECK1(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - DOUBLE PRECISION SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER I, LEN, NP1 -* .. Local Arrays .. - DOUBLE PRECISION DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2), - + SA(10), STEMP(1), STRUE(8), SX(8) - INTEGER ITRUE2(5) -* .. External Functions .. - DOUBLE PRECISION DASUM, DNRM2 - INTEGER IDAMAX - EXTERNAL DASUM, DNRM2, IDAMAX -* .. External Subroutines .. - EXTERNAL ITEST1, DSCAL, STEST, STEST1 -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA SA/0.3D0, -1.0D0, 0.0D0, 1.0D0, 0.3D0, 0.3D0, - + 0.3D0, 0.3D0, 0.3D0, 0.3D0/ - DATA DV/0.1D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, - + 2.0D0, 2.0D0, 0.3D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0, - + 3.0D0, 3.0D0, 3.0D0, 0.3D0, -0.4D0, 4.0D0, - + 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 0.2D0, - + -0.6D0, 0.3D0, 5.0D0, 5.0D0, 5.0D0, 5.0D0, - + 5.0D0, 0.1D0, -0.3D0, 0.5D0, -0.1D0, 6.0D0, - + 6.0D0, 6.0D0, 6.0D0, 0.1D0, 8.0D0, 8.0D0, 8.0D0, - + 8.0D0, 8.0D0, 8.0D0, 8.0D0, 0.3D0, 9.0D0, 9.0D0, - + 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 0.3D0, 2.0D0, - + -0.4D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, - + 0.2D0, 3.0D0, -0.6D0, 5.0D0, 0.3D0, 2.0D0, - + 2.0D0, 2.0D0, 0.1D0, 4.0D0, -0.3D0, 6.0D0, - + -0.5D0, 7.0D0, -0.1D0, 3.0D0/ - DATA DTRUE1/0.0D0, 0.3D0, 0.5D0, 0.7D0, 0.6D0/ - DATA DTRUE3/0.0D0, 0.3D0, 0.7D0, 1.1D0, 1.0D0/ - DATA DTRUE5/0.10D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, - + 2.0D0, 2.0D0, 2.0D0, -0.3D0, 3.0D0, 3.0D0, - + 3.0D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0, 0.0D0, 0.0D0, - + 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, - + 0.20D0, -0.60D0, 0.30D0, 5.0D0, 5.0D0, 5.0D0, - + 5.0D0, 5.0D0, 0.03D0, -0.09D0, 0.15D0, -0.03D0, - + 6.0D0, 6.0D0, 6.0D0, 6.0D0, 0.10D0, 8.0D0, - + 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0, - + 0.09D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, - + 9.0D0, 9.0D0, 0.09D0, 2.0D0, -0.12D0, 2.0D0, - + 2.0D0, 2.0D0, 2.0D0, 2.0D0, 0.06D0, 3.0D0, - + -0.18D0, 5.0D0, 0.09D0, 2.0D0, 2.0D0, 2.0D0, - + 0.03D0, 4.0D0, -0.09D0, 6.0D0, -0.15D0, 7.0D0, - + -0.03D0, 3.0D0/ - DATA ITRUE2/0, 1, 2, 2, 3/ -* .. Executable Statements .. - DO 80 INCX = 1, 2 - DO 60 NP1 = 1, 5 - N = NP1 - 1 - LEN = 2*MAX(N,1) -* .. Set vector arguments .. - DO 20 I = 1, LEN - SX(I) = DV(I,NP1,INCX) - 20 CONTINUE -* - IF (ICASE.EQ.7) THEN -* .. DNRM2 .. - STEMP(1) = DTRUE1(NP1) - CALL STEST1(DNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC) - ELSE IF (ICASE.EQ.8) THEN -* .. DASUM .. - STEMP(1) = DTRUE3(NP1) - CALL STEST1(DASUM(N,SX,INCX),STEMP(1),STEMP,SFAC) - ELSE IF (ICASE.EQ.9) THEN -* .. DSCAL .. - CALL DSCAL(N,SA((INCX-1)*5+NP1),SX,INCX) - DO 40 I = 1, LEN - STRUE(I) = DTRUE5(I,NP1,INCX) - 40 CONTINUE - CALL STEST(LEN,SX,STRUE,STRUE,SFAC) - ELSE IF (ICASE.EQ.10) THEN -* .. IDAMAX .. - CALL ITEST1(IDAMAX(N,SX,INCX),ITRUE2(NP1)) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' - STOP - END IF - 60 CONTINUE - 80 CONTINUE - RETURN - END - SUBROUTINE CHECK2(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - DOUBLE PRECISION SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - DOUBLE PRECISION SA - INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY, - $ MX, MY -* .. Local Arrays .. - DOUBLE PRECISION DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), - $ DT8(7,4,4), DX1(7), - $ DY1(7), SSIZE1(4), SSIZE2(14,2), SSIZE(7), - $ STX(7), STY(7), SX(7), SY(7), - $ DPAR(5,4), DT19X(7,4,16),DT19XA(7,4,4), - $ DT19XB(7,4,4), DT19XC(7,4,4),DT19XD(7,4,4), - $ DT19Y(7,4,16), DT19YA(7,4,4),DT19YB(7,4,4), - $ DT19YC(7,4,4), DT19YD(7,4,4), DTEMP(5) - INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) -* .. External Functions .. - DOUBLE PRECISION DDOT, DSDOT - EXTERNAL DDOT, DSDOT -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DROTM, DSWAP, STEST, STEST1 -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - EQUIVALENCE (DT19X(1,1,1),DT19XA(1,1,1)),(DT19X(1,1,5), - A DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)), - B (DT19X(1,1,13),DT19XD(1,1,1)) - EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5), - A DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)), - B (DT19Y(1,1,13),DT19YD(1,1,1)) - - DATA SA/0.3D0/ - 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 DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0, - + -0.4D0/ - DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0, - + 0.8D0/ - DATA DT7/0.0D0, 0.30D0, 0.21D0, 0.62D0, 0.0D0, - + 0.30D0, -0.07D0, 0.85D0, 0.0D0, 0.30D0, -0.79D0, - + -0.74D0, 0.0D0, 0.30D0, 0.33D0, 1.27D0/ - DATA DT8/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.15D0, - + 0.94D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.68D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.35D0, -0.9D0, 0.48D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.38D0, -0.9D0, 0.57D0, 0.7D0, -0.75D0, - + 0.2D0, 0.98D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.68D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.35D0, -0.72D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.38D0, - + -0.63D0, 0.15D0, 0.88D0, 0.0D0, 0.0D0, 0.0D0, - + 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.7D0, - + -0.75D0, 0.2D0, 1.04D0/ - DATA DT10X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.5D0, -0.9D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.5D0, -0.9D0, 0.3D0, 0.7D0, - + 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.3D0, 0.1D0, 0.5D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.8D0, 0.1D0, -0.6D0, - + 0.8D0, 0.3D0, -0.3D0, 0.5D0, 0.6D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.9D0, - + 0.1D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0, - + 0.1D0, 0.3D0, 0.8D0, -0.9D0, -0.3D0, 0.5D0, - + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.5D0, 0.3D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.5D0, 0.3D0, -0.6D0, 0.8D0, 0.0D0, 0.0D0, - + 0.0D0/ - DATA DT10Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.6D0, 0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.0D0, - + 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, -0.5D0, -0.9D0, 0.6D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, -0.4D0, -0.9D0, 0.9D0, - + 0.7D0, -0.5D0, 0.2D0, 0.6D0, 0.5D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.5D0, - + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + -0.4D0, 0.9D0, -0.5D0, 0.6D0, 0.0D0, 0.0D0, - + 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.7D0, - + -0.5D0, 0.2D0, 0.8D0/ - DATA SSIZE1/0.0D0, 0.3D0, 1.6D0, 3.2D0/ - DATA SSIZE2/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/ -* -* FOR DROTM -* - DATA DPAR/-2.D0, 0.D0,0.D0,0.D0,0.D0, - A -1.D0, 2.D0, -3.D0, -4.D0, 5.D0, - B 0.D0, 0.D0, 2.D0, -3.D0, 0.D0, - C 1.D0, 5.D0, 2.D0, 0.D0, -4.D0/ -* TRUE X RESULTS F0R ROTATIONS DROTM - DATA DT19XA/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - I -.8D0, 3.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - J -.9D0, 2.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - K 3.5D0, -.4D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - L .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, - M -.8D0, 3.8D0, -2.2D0, -1.2D0, 0.D0,0.D0,0.D0, - N -.9D0, 2.8D0, -1.4D0, -1.3D0, 0.D0,0.D0,0.D0, - O 3.5D0, -.4D0, -2.2D0, 4.7D0, 0.D0,0.D0,0.D0/ -* - DATA DT19XB/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, - I 0.D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, - J -.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, - K 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, - L .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, - M -2.0D0, .1D0, 1.4D0, .8D0, .6D0, -.3D0, -2.8D0, - N -1.8D0, .1D0, 1.3D0, .8D0, 0.D0, -.3D0, -1.9D0, - O 3.8D0, .1D0, -3.1D0, .8D0, 4.8D0, -.3D0, -1.5D0 / -* - DATA DT19XC/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, - I 4.8D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, - J 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, - K 2.1D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, - L .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, - M -1.6D0, .1D0, -2.2D0, .8D0, 5.4D0, -.3D0, -2.8D0, - N -1.5D0, .1D0, -1.4D0, .8D0, 3.6D0, -.3D0, -1.9D0, - O 3.7D0, .1D0, -2.2D0, .8D0, 3.6D0, -.3D0, -1.5D0 / -* - DATA DT19XD/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - I -.8D0, -1.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - J -.9D0, -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - K 3.5D0, .8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - L .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, - M -.8D0, -1.0D0, 1.4D0, -1.6D0, 0.D0,0.D0,0.D0, - N -.9D0, -.8D0, 1.3D0, -1.6D0, 0.D0,0.D0,0.D0, - O 3.5D0, .8D0, -3.1D0, 4.8D0, 0.D0,0.D0,0.D0/ -* TRUE Y RESULTS FOR ROTATIONS DROTM - DATA DT19YA/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - I .7D0, -4.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - J 1.7D0, -.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - K -2.6D0, 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - L .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, - M .7D0, -4.8D0, 3.0D0, 1.1D0, 0.D0,0.D0,0.D0, - N 1.7D0, -.7D0, -.7D0, 2.3D0, 0.D0,0.D0,0.D0, - O -2.6D0, 3.5D0, -.7D0, -3.6D0, 0.D0,0.D0,0.D0/ -* - DATA DT19YB/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, - I 4.0D0, -.9D0, -.3D0, 0.D0,0.D0,0.D0,0.D0, - J -.5D0, -.9D0, 1.5D0, 0.D0,0.D0,0.D0,0.D0, - K -1.5D0, -.9D0, -1.8D0, 0.D0,0.D0,0.D0,0.D0, - L .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, - M 3.7D0, -.9D0, -1.2D0, .7D0, -1.5D0, .2D0, 2.2D0, - N -.3D0, -.9D0, 2.1D0, .7D0, -1.6D0, .2D0, 2.0D0, - O -1.6D0, -.9D0, -2.1D0, .7D0, 2.9D0, .2D0, -3.8D0 / -* - DATA DT19YC/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - I 4.0D0, -6.3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - J -.5D0, .3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - K -1.5D0, 3.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, - L .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, - M 3.7D0, -7.2D0, 3.0D0, 1.7D0, 0.D0,0.D0,0.D0, - N -.3D0, .9D0, -.7D0, 1.9D0, 0.D0,0.D0,0.D0, - O -1.6D0, 2.7D0, -.7D0, -3.4D0, 0.D0,0.D0,0.D0/ -* - DATA DT19YD/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, - H .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, - I .7D0, -.9D0, 1.2D0, 0.D0,0.D0,0.D0,0.D0, - J 1.7D0, -.9D0, .5D0, 0.D0,0.D0,0.D0,0.D0, - K -2.6D0, -.9D0, -1.3D0, 0.D0,0.D0,0.D0,0.D0, - L .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, - M .7D0, -.9D0, 1.2D0, .7D0, -1.5D0, .2D0, 1.6D0, - N 1.7D0, -.9D0, .5D0, .7D0, -1.6D0, .2D0, 2.4D0, - O -2.6D0, -.9D0, -1.3D0, .7D0, 2.9D0, .2D0, -4.0D0 / -* -* .. Executable Statements .. -* - DO 120 KI = 1, 4 - INCX = INCXS(KI) - INCY = INCYS(KI) - MX = ABS(INCX) - MY = ABS(INCY) -* - DO 100 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 - SX(I) = DX1(I) - SY(I) = DY1(I) - 20 CONTINUE -* - IF (ICASE.EQ.1) THEN -* .. DDOT .. - CALL STEST1(DDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN) - + ,SFAC) - ELSE IF (ICASE.EQ.2) THEN -* .. DAXPY .. - CALL DAXPY(N,SA,SX,INCX,SY,INCY) - DO 40 J = 1, LENY - STY(J) = DT8(J,KN,KI) - 40 CONTINUE - CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) - ELSE IF (ICASE.EQ.5) THEN -* .. DCOPY .. - DO 60 I = 1, 7 - STY(I) = DT10Y(I,KN,KI) - 60 CONTINUE - CALL DCOPY(N,SX,INCX,SY,INCY) - CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0) - ELSE IF (ICASE.EQ.6) THEN -* .. DSWAP .. - CALL DSWAP(N,SX,INCX,SY,INCY) - DO 80 I = 1, 7 - STX(I) = DT10X(I,KN,KI) - STY(I) = DT10Y(I,KN,KI) - 80 CONTINUE - CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0D0) - CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0) - ELSE IF (ICASE.EQ.12) THEN -* .. DROTM .. - KNI=KN+4*(KI-1) - DO KPAR=1,4 - DO I=1,7 - SX(I) = DX1(I) - SY(I) = DY1(I) - STX(I)= DT19X(I,KPAR,KNI) - STY(I)= DT19Y(I,KPAR,KNI) - END DO -* - DO I=1,5 - DTEMP(I) = DPAR(I,KPAR) - END DO -* - DO I=1,LENX - SSIZE(I)=STX(I) - END DO -* SEE REMARK ABOVE ABOUT DT11X(1,2,7) -* AND DT11X(5,3,8). - IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7)) - $ SSIZE(1) = 2.4D0 - IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8)) - $ SSIZE(5) = 1.8D0 -* - CALL DROTM(N,SX,INCX,SY,INCY,DTEMP) - CALL STEST(LENX,SX,STX,SSIZE,SFAC) - CALL STEST(LENY,SY,STY,STY,SFAC) - END DO - ELSE IF (ICASE.EQ.13) THEN -* .. DSDOT .. - CALL TESTDSDOT(REAL(DSDOT(N,REAL(SX),INCX,REAL(SY),INCY)), - $ REAL(DT7(KN,KI)),REAL(SSIZE1(KN)), .3125E-1) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' - STOP - END IF - 100 CONTINUE - 120 CONTINUE - RETURN - END - SUBROUTINE CHECK3(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - DOUBLE PRECISION SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - DOUBLE PRECISION SC, SS - INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY -* .. Local Arrays .. - DOUBLE PRECISION COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4), - + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5), - + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5), - + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7), - + SY(7) - INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11), - + MWPINY(11), MWPN(11), NS(4) -* .. External Subroutines .. - EXTERNAL DROT, STEST -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - 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 DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0, - + -0.4D0/ - DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0, - + 0.8D0/ - DATA SC, SS/0.8D0, 0.6D0/ - DATA DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0, - + 1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0, - + -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0, - + -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0, - + 0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0, - + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0, - + 0.0D0, 0.0D0, 0.0D0/ - DATA DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0, - + 0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0, - + -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0, - + 0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0, - + 0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, - + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, - + 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0, - + 0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0, - + -0.18D0, 0.2D0, 0.16D0/ - DATA SSIZE2/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/ -* .. 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) -* - IF (ICASE.EQ.4) THEN -* .. DROT .. - DO 20 I = 1, 7 - SX(I) = DX1(I) - SY(I) = DY1(I) - STX(I) = DT9X(I,KN,KI) - STY(I) = DT9Y(I,KN,KI) - 20 CONTINUE - CALL DROT(N,SX,INCX,SY,INCY,SC,SS) - CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC) - CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK3' - STOP - END IF - 40 CONTINUE - 60 CONTINUE -* - MWPC(1) = 1 - DO 80 I = 2, 11 - MWPC(I) = 0 - 80 CONTINUE - MWPS(1) = 0 - DO 100 I = 2, 6 - MWPS(I) = 1 - 100 CONTINUE - DO 120 I = 7, 11 - MWPS(I) = -1 - 120 CONTINUE - MWPINX(1) = 1 - MWPINX(2) = 1 - MWPINX(3) = 1 - MWPINX(4) = -1 - MWPINX(5) = 1 - MWPINX(6) = -1 - MWPINX(7) = 1 - MWPINX(8) = 1 - MWPINX(9) = -1 - MWPINX(10) = 1 - MWPINX(11) = -1 - MWPINY(1) = 1 - MWPINY(2) = 1 - MWPINY(3) = -1 - MWPINY(4) = -1 - MWPINY(5) = 2 - MWPINY(6) = 1 - MWPINY(7) = 1 - MWPINY(8) = -1 - MWPINY(9) = -1 - MWPINY(10) = 2 - MWPINY(11) = 1 - DO 140 I = 1, 11 - MWPN(I) = 5 - 140 CONTINUE - MWPN(5) = 3 - MWPN(10) = 3 - DO 160 I = 1, 5 - MWPX(I) = I - MWPY(I) = I - MWPTX(1,I) = I - MWPTY(1,I) = I - MWPTX(2,I) = I - MWPTY(2,I) = -I - MWPTX(3,I) = 6 - I - MWPTY(3,I) = I - 6 - MWPTX(4,I) = I - MWPTY(4,I) = -I - MWPTX(6,I) = 6 - I - MWPTY(6,I) = I - 6 - MWPTX(7,I) = -I - MWPTY(7,I) = I - MWPTX(8,I) = I - 6 - MWPTY(8,I) = 6 - I - MWPTX(9,I) = -I - MWPTY(9,I) = I - MWPTX(11,I) = I - 6 - MWPTY(11,I) = 6 - I - 160 CONTINUE - MWPTX(5,1) = 1 - MWPTX(5,2) = 3 - MWPTX(5,3) = 5 - MWPTX(5,4) = 4 - MWPTX(5,5) = 5 - MWPTY(5,1) = -1 - MWPTY(5,2) = 2 - MWPTY(5,3) = -2 - MWPTY(5,4) = 4 - MWPTY(5,5) = -3 - MWPTX(10,1) = -1 - MWPTX(10,2) = -3 - MWPTX(10,3) = -5 - MWPTX(10,4) = 4 - MWPTX(10,5) = 5 - MWPTY(10,1) = 1 - MWPTY(10,2) = 2 - MWPTY(10,3) = 2 - MWPTY(10,4) = 4 - MWPTY(10,5) = 3 - DO 200 I = 1, 11 - INCX = MWPINX(I) - INCY = MWPINY(I) - DO 180 K = 1, 5 - COPYX(K) = MWPX(K) - COPYY(K) = MWPY(K) - MWPSTX(K) = MWPTX(I,K) - MWPSTY(K) = MWPTY(I,K) - 180 CONTINUE - CALL DROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I)) - CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC) - CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC) - 200 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, 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, 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, I, SCOMP(I), - + STRUE(I), SD, SSIZE(I) - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY I ', - + ' COMP(I) TRUE(I) DIFFERENCE', - + ' SIZE(I)',/1X) -99997 FORMAT (1X,I4,I3,2I5,I3,2D36.8,2D12.4) - END - SUBROUTINE TESTDSDOT(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, SCOMP, SSIZE, STRUE -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - REAL SD -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Executable Statements .. -* - SD = SCOMP - STRUE - IF (ABS(SFAC*SD) .LE. ABS(SSIZE) * 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, SCOMP, - + STRUE, SD, SSIZE - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY ', - + ' COMP(I) TRUE(I) DIFFERENCE', - + ' SIZE(I)',/1X) -99997 FORMAT (1X,I4,I3,1I5,I3,2E36.8,2E12.4) - END - SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) -* ************************* STEST1 ***************************** -* -* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN -* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE -* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. -* -* C.L. LAWSON, JPL, 1978 DEC 6 -* -* .. Scalar Arguments .. - 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 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, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER ID -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, 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, ICOMP, ITRUE, ID - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY ', - + ' COMP TRUE DIFFERENCE', - + /1X) -99997 FORMAT (1X,I4,I3,2I5,2I36,I12) - END diff --git a/eigen/blas/testing/dblat2.dat b/eigen/blas/testing/dblat2.dat deleted file mode 100644 index 3755b83..0000000 --- a/eigen/blas/testing/dblat2.dat +++ /dev/null @@ -1,34 +0,0 @@ -'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. diff --git a/eigen/blas/testing/dblat2.f b/eigen/blas/testing/dblat2.f deleted file mode 100644 index 0fa80af..0000000 --- a/eigen/blas/testing/dblat2.f +++ /dev/null @@ -1,3176 +0,0 @@ -*> \brief \b DBLAT2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM DBLAT2 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the DOUBLE PRECISION Level 2 Blas. -*> -*> The program must be driven by a short data file. The first 18 records -*> of the file are read using list-directed input, the last 16 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 34 lines: -*> 'dblat2.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 4 NUMBER OF VALUES OF K -*> 0 1 2 4 VALUES OF K -*> 4 NUMBER OF VALUES OF INCX AND INCY -*> 1 2 -1 -2 VALUES OF INCX AND INCY -*> 3 NUMBER OF VALUES OF ALPHA -*> 0.0 1.0 0.7 VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> 0.0 1.0 0.9 VALUES OF BETAC -*> DGEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DGBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DSBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DSPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRSV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTBSV T PUT F FOR NO TEST. SAME COLUMNS. -*> DTPSV T PUT F FOR NO TEST. SAME COLUMNS. -*> DGER T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYR T PUT F FOR NO TEST. SAME COLUMNS. -*> DSPR T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> DSPR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. -*> An extended set of Fortran Basic Linear Algebra Subprograms. -*> -*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics -*> and Computer Science Division, Argonne National Laboratory, -*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> Or -*> -*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms -*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford -*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st -*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. -*> -*> -*> -- Written on 10-August-1987. -*> Richard Hanson, Sandia National Labs. -*> Jeremy Du Croz, NAG Central Office. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup double_blas_testing -* -* ===================================================================== - PROGRAM DBLAT2 -* -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 16 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - INTEGER NMAX, INCMAX - PARAMETER ( NMAX = 65, INCMAX = 2 ) - INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX - PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, - $ NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, - $ NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANS - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), - $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( 2*NMAX ) - INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - DOUBLE PRECISION DDIFF - LOGICAL LDE - EXTERNAL DDIFF, LDE -* .. External Subroutines .. - EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6, - $ DCHKE, DMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ', - $ 'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ', - $ 'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER ', - $ 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 '/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 230 - END IF - 10 CONTINUE -* Values of K - READ( NIN, FMT = * )NKB - IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN - WRITE( NOUT, FMT = 9997 )'K', NKBMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) - DO 20 I = 1, NKB - IF( KB( I ).LT.0 )THEN - WRITE( NOUT, FMT = 9995 ) - GO TO 230 - END IF - 20 CONTINUE -* Values of INCX and INCY - READ( NIN, FMT = * )NINC - IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN - WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) - DO 30 I = 1, NINC - IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN - WRITE( NOUT, FMT = 9994 )INCMAX - GO TO 230 - END IF - 30 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9993 ) - WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) - WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) - WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9980 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 40 I = 1, NSUBS - LTEST( I ) = .FALSE. - 40 CONTINUE - 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT - DO 60 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 70 - 60 CONTINUE - WRITE( NOUT, FMT = 9986 )SNAMET - STOP - 70 LTEST( I ) = LTESTT - GO TO 50 -* - 80 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(ZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of DMVCH using exact data. -* - N = MIN( 32, NMAX ) - DO 120 J = 1, N - DO 110 I = 1, N - A( I, J ) = MAX( I - J + 1, 0 ) - 110 CONTINUE - X( J ) = J - Y( J ) = ZERO - 120 CONTINUE - DO 130 J = 1, N - YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE -* YY holds the exact result. On exit from DMVCH YT holds -* the result computed by DMVCH. - TRANS = 'N' - CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF - TRANS = 'T' - CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 210 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 140, 150, 150, 150, 160, 160, - $ 160, 160, 160, 160, 170, 180, 180, - $ 190, 190 )ISNUM -* Test DGEMV, 01, and DGBMV, 02. - 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05. - 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test DTRMV, 06, DTBMV, 07, DTPMV, 08, -* DTRSV, 09, DTBSV, 10, and DTPSV, 11. - 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) - GO TO 200 -* Test DGER, 12. - 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test DSYR, 13, and DSPR, 14. - 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test DSYR2, 15, and DSPR2, 16. - 190 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) -* - 200 IF( FATAL.AND.SFATAL ) - $ GO TO 220 - END IF - 210 CONTINUE - WRITE( NOUT, FMT = 9982 ) - GO TO 240 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9981 ) - GO TO 240 -* - 230 CONTINUE - WRITE( NOUT, FMT = 9987 ) -* - 240 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) - 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', - $ I2 ) - 9993 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9992 FORMAT( ' FOR N ', 9I6 ) - 9991 FORMAT( ' FOR K ', 7I6 ) - 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) - 9989 FORMAT( ' FOR ALPHA ', 7F6.1 ) - 9988 FORMAT( ' FOR BETA ', 7F6.1 ) - 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1, - $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / - $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' - $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9982 FORMAT( /' END OF TESTS' ) - 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of DBLAT2. -* - END - SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests DGEMV and DGBMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, - $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, - $ NL, NS - LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN - CHARACTER*1 TRANS, TRANSS - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DGBMV, DGEMV, DMAKE, DMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 11 - ELSE IF( BANDED )THEN - NARGS = 13 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IKU = 1, NK - IF( BANDED )THEN - KU = KB( IKU ) - KL = MAX( KU - 1, 0 ) - ELSE - KU = N - 1 - KL = M - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = KL + KU + 1 - ELSE - LDA = M - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, - $ LDA, KL, KU, RESET, TRANSL ) -* - DO 90 IC = 1, 3 - TRANS = ICH( IC: IC ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' -* - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*NL -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, - $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) - IF( NL.GT.1 )THEN - X( NL/2 ) = ZERO - XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*ML -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL DMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, - $ YY, ABS( INCY ), 0, ML - 1, - $ RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANSS = TRANS - MS = M - NS = N - KLS = KL - KUS = KU - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ TRANS, M, N, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL DGEMV( TRANS, M, N, ALPHA, AA, - $ LDA, XX, INCX, BETA, YY, - $ INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANS, M, N, KL, KU, ALPHA, LDA, - $ INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL DGBMV( TRANS, M, N, KL, KU, ALPHA, - $ AA, LDA, XX, INCX, BETA, - $ YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 130 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANS.EQ.TRANSS - ISAME( 2 ) = MS.EQ.M - ISAME( 3 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LDE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LDE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LDERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 4 ) = KLS.EQ.KL - ISAME( 5 ) = KUS.EQ.KU - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LDE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LDE( XS, XX, LX ) - ISAME( 10 ) = INCXS.EQ.INCX - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 12 ) = LDERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 13 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 130 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL DMVCH( TRANS, M, N, ALPHA, A, - $ NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 130 - ELSE -* Avoid repeating tests with M.le.0 or -* N.le.0. - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 140 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, - $ ALPHA, LDA, INCX, BETA, INCY - END IF -* - 140 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, - $ ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK1. -* - END - SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests DSYMV, DSBMV and DSPMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, - $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DSBMV, DSPMV, DSYMV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 10 - ELSE IF( BANDED )THEN - NARGS = 11 - ELSE IF( PACKED )THEN - NARGS = 9 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, - $ LDA, K, K, RESET, TRANSL ) -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - UPLOS = UPLO - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL DSYMV( UPLO, N, ALPHA, AA, LDA, XX, - $ INCX, BETA, YY, INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, N, K, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL DSBMV( UPLO, N, K, ALPHA, AA, LDA, - $ XX, INCX, BETA, YY, INCY ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, N, ALPHA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL DSPMV( UPLO, N, ALPHA, AA, XX, INCX, - $ BETA, YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( AS, AA, LAA ) - ISAME( 5 ) = LDAS.EQ.LDA - ISAME( 6 ) = LDE( XS, XX, LX ) - ISAME( 7 ) = INCXS.EQ.INCX - ISAME( 8 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 9 ) = LDERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 10 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 3 ) = KS.EQ.K - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LDE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LDE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LDERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( PACKED )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( AS, AA, LAA ) - ISAME( 5 ) = LDE( XS, XX, LX ) - ISAME( 6 ) = INCXS.EQ.INCX - ISAME( 7 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 8 ) = LDE( YS, YY, LY ) - ELSE - ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 9 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X, - $ INCX, BETA, Y, INCY, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0 - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, - $ BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ BETA, INCY - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP', - $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, - $ ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', - $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK2. -* - END - SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) -* -* Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XT( NMAX ), - $ XX( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - DOUBLE PRECISION ERR, ERRMAX, TRANSL - INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, - $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHD, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DTBMV, DTBSV, DTPMV, DTPSV, - $ DTRMV, DTRSV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'R' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 8 - ELSE IF( BANDED )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 7 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* Set up zero vector for DMVCH. - DO 10 I = 1, NMAX - Z( I ) = ZERO - 10 CONTINUE -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) -* - DO 70 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, - $ NMAX, AA, LDA, K, K, RESET, TRANSL ) -* - DO 60 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, - $ TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - DIAGS = DIAG - NS = N - KS = K - DO 20 I = 1, LAA - AS( I ) = AA( I ) - 20 CONTINUE - LDAS = LDA - DO 30 I = 1, LX - XS( I ) = XX( I ) - 30 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTRMV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTBMV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTPMV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTRSV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTBSV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL DTPSV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = TRANS.EQ.TRANSS - ISAME( 3 ) = DIAG.EQ.DIAGS - ISAME( 4 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 5 ) = LDE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 7 ) = LDE( XS, XX, LX ) - ELSE - ISAME( 7 ) = LDERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 8 ) = INCXS.EQ.INCX - ELSE IF( BANDED )THEN - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = LDE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 8 ) = LDE( XS, XX, LX ) - ELSE - ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 9 ) = INCXS.EQ.INCX - ELSE IF( PACKED )THEN - ISAME( 5 ) = LDE( AS, AA, LAA ) - IF( NULL )THEN - ISAME( 6 ) = LDE( XS, XX, LX ) - ELSE - ISAME( 6 ) = LDERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 7 ) = INCXS.EQ.INCX - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MV' )THEN -* -* Check the result. -* - CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, - $ INCX, ZERO, Z, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN -* -* Compute approximation to original vector. -* - DO 50 I = 1, N - Z( I ) = XX( 1 + ( I - 1 )* - $ ABS( INCX ) ) - XX( 1 + ( I - 1 )*ABS( INCX ) ) - $ = X( I ) - 50 CONTINUE - CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z, - $ INCX, ZERO, X, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .FALSE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0. - GO TO 110 - END IF -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, - $ INCX - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, - $ LDA, INCX - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', - $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), - $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', - $ I3, ', X,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK3. -* - END - SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests DGER. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, - $ NC, ND, NS - LOGICAL NULL, RESET, SAME -* .. Local Arrays .. - DOUBLE PRECISION W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DGER, DMAKE, DMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* Define the number of arguments. - NARGS = 9 -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* -* Set LDA to 1 more than minimum value if room. - LDA = M - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 100 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*M -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), - $ 0, M - 1, RESET, TRANSL ) - IF( M.GT.1 )THEN - X( M/2 ) = ZERO - XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO - END IF -* - DO 90 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, - $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL DGER( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 140 - END IF -* -* See what data changed inside subroutine. -* - ISAME( 1 ) = MS.EQ.M - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LDE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LDE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LDERES( 'GE', ' ', M, N, AS, AA, - $ LDA ) - END IF - ISAME( 9 ) = LDAS.EQ.LDA -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 140 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, M - Z( I ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, M - Z( I ) = X( M - I + 1 ) - 60 CONTINUE - END IF - DO 70 J = 1, N - IF( INCY.GT.0 )THEN - W( 1 ) = Y( J ) - ELSE - W( 1 ) = Y( N - J + 1 ) - END IF - CALL DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, - $ ONE, A( 1, J ), 1, YT, G, - $ AA( 1 + ( J - 1 )*LDA ), EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 130 - 70 CONTINUE - ELSE -* Avoid repeating tests with M.le.0 or N.le.0. - GO TO 110 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 150 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 140 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2, - $ ', Y,', I2, ', A,', I3, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK4. -* - END - SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests DSYR and DSPR. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, - $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - DOUBLE PRECISION W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DSPR, DSYR -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 7 - ELSE IF( PACKED )THEN - NARGS = 6 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, - $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, LDA - IF( REWI ) - $ REWIND NTRA - CALL DSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX - IF( REWI ) - $ REWIND NTRA - CALL DSPR( UPLO, N, ALPHA, XX, INCX, AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - IF( NULL )THEN - ISAME( 6 ) = LDE( AS, AA, LAA ) - ELSE - ISAME( 6 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, AS, - $ AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 7 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 40 I = 1, N - Z( I ) = X( I ) - 40 CONTINUE - ELSE - DO 50 I = 1, N - Z( I ) = X( N - I + 1 ) - 50 CONTINUE - END IF - JA = 1 - DO 60 J = 1, N - W( 1 ) = Z( J ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, - $ 1, ONE, A( JJ, J ), 1, YT, G, - $ AA( JA ), EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 110 - 60 CONTINUE - ELSE -* Avoid repeating tests if N.le.0. - IF( N.LE.0 ) - $ GO TO 100 - END IF -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK5. -* - END - SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests DSYR2 and DSPR2. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, - $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - DOUBLE PRECISION W( 2 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DSPR2, DSYR2 -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 8 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 140 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 140 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 130 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 120 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 110 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 100 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, - $ NMAX, AA, LDA, N - 1, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL DSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY - IF( REWI ) - $ REWIND NTRA - CALL DSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 160 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LDE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LDE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LDE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, - $ AS, AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 9 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 160 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, N - Z( I, 1 ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - Z( I, 1 ) = X( N - I + 1 ) - 60 CONTINUE - END IF - IF( INCY.GT.0 )THEN - DO 70 I = 1, N - Z( I, 2 ) = Y( I ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - Z( I, 2 ) = Y( N - I + 1 ) - 80 CONTINUE - END IF - JA = 1 - DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) - W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), - $ NMAX, W, 1, ONE, A( JJ, J ), 1, - $ YT, G, AA( JA ), EPS, ERR, FATAL, - $ NOUT, .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 150 - 90 CONTINUE - ELSE -* Avoid repeating tests with N.le.0. - IF( N.LE.0 ) - $ GO TO 140 - END IF -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 170 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 160 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ INCY, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY - END IF -* - 170 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', Y,', I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', Y,', I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK6. -* - END - SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 2 Blas. -* Requires a special version of the error-handling routine XERBLA. -* ALPHA, BETA, A, X and Y should not need to be defined. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, BETA -* .. Local Arrays .. - DOUBLE PRECISION A( 1, 1 ), X( 1 ), Y( 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, DGBMV, DGEMV, DGER, DSBMV, DSPMV, DSPR, - $ DSPR2, DSYMV, DSYR, DSYR2, DTBMV, DTBSV, DTPMV, - $ DTPSV, DTRMV, DTRSV -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90, 100, 110, 120, 130, 140, 150, - $ 160 )ISNUM - 10 INFOT = 1 - CALL DGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 20 INFOT = 1 - CALL DGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 30 INFOT = 1 - CALL DSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 40 INFOT = 1 - CALL DSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 50 INFOT = 1 - CALL DSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 60 INFOT = 1 - CALL DTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 70 INFOT = 1 - CALL DTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 80 INFOT = 1 - CALL DTPMV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTPMV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTPMV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTPMV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTPMV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 90 INFOT = 1 - CALL DTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 100 INFOT = 1 - CALL DTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 110 INFOT = 1 - CALL DTPSV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTPSV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTPSV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTPSV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTPSV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 120 INFOT = 1 - CALL DGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 130 INFOT = 1 - CALL DSYR( '/', 0, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYR( 'U', -1, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSYR( 'U', 0, ALPHA, X, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR( 'U', 2, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 140 INFOT = 1 - CALL DSPR( '/', 0, ALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSPR( 'U', -1, ALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSPR( 'U', 0, ALPHA, X, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 150 INFOT = 1 - CALL DSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 160 INFOT = 1 - CALL DSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 170 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of DCHKE. -* - END - SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, - $ KU, RESET, TRANSL ) -* -* Generates values for an M by N matrix A within the bandwidth -* defined by KL and KU. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION ROGUE - PARAMETER ( ROGUE = -1.0D10 ) -* .. Scalar Arguments .. - DOUBLE PRECISION TRANSL - INTEGER KL, KU, LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - DOUBLE PRECISION DBEG - EXTERNAL DBEG -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Executable Statements .. - GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'S' - TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - IF( ( I.LE.J.AND.J - I.LE.KU ).OR. - $ ( I.GE.J.AND.I - J.LE.KL ) )THEN - A( I, J ) = DBEG( RESET ) + TRANSL - ELSE - A( I, J ) = ZERO - END IF - IF( I.NE.J )THEN - IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'GB' )THEN - DO 90 J = 1, N - DO 60 I1 = 1, KU + 1 - J - AA( I1 + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) - AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) - 70 CONTINUE - DO 80 I3 = I2, LDA - AA( I3 + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 130 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 100 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 100 CONTINUE - DO 110 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 110 CONTINUE - DO 120 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 120 CONTINUE - 130 CONTINUE - ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN - DO 170 J = 1, N - IF( UPPER )THEN - KK = KL + 1 - IBEG = MAX( 1, KL + 2 - J ) - IF( UNIT )THEN - IEND = KL - ELSE - IEND = KL + 1 - END IF - ELSE - KK = 1 - IF( UNIT )THEN - IBEG = 2 - ELSE - IBEG = 1 - END IF - IEND = MIN( KL + 1, 1 + M - J ) - END IF - DO 140 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 140 CONTINUE - DO 150 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) - 150 CONTINUE - DO 160 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 160 CONTINUE - 170 CONTINUE - ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN - IOFF = 0 - DO 190 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 180 I = IBEG, IEND - IOFF = IOFF + 1 - AA( IOFF ) = A( I, J ) - IF( I.EQ.J )THEN - IF( UNIT ) - $ AA( IOFF ) = ROGUE - END IF - 180 CONTINUE - 190 CONTINUE - END IF - RETURN -* -* End of DMAKE. -* - END - SUBROUTINE DMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA, EPS, ERR - INTEGER INCX, INCY, M, N, NMAX, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), - $ YY( * ) -* .. Local Scalars .. - DOUBLE PRECISION ERRI - INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL - LOGICAL TRAN -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. Executable Statements .. - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF - IF( INCX.LT.0 )THEN - KX = NL - INCXL = -1 - ELSE - KX = 1 - INCXL = 1 - END IF - IF( INCY.LT.0 )THEN - KY = ML - INCYL = -1 - ELSE - KY = 1 - INCYL = 1 - END IF -* -* Compute expected result in YT using data in A, X and Y. -* Compute gauges in G. -* - IY = KY - DO 30 I = 1, ML - YT( IY ) = ZERO - G( IY ) = ZERO - JX = KX - IF( TRAN )THEN - DO 10 J = 1, NL - YT( IY ) = YT( IY ) + A( J, I )*X( JX ) - G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) ) - JX = JX + INCXL - 10 CONTINUE - ELSE - DO 20 J = 1, NL - YT( IY ) = YT( IY ) + A( I, J )*X( JX ) - G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) ) - JX = JX + INCXL - 20 CONTINUE - END IF - YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) - G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) ) - IY = IY + INCYL - 30 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 40 I = 1, ML - ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS - IF( G( I ).NE.ZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.ONE ) - $ GO TO 50 - 40 CONTINUE -* If the loop completes, all results are at least half accurate. - GO TO 70 -* -* Report fatal error. -* - 50 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 60 I = 1, ML - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, YT( I ), - $ YY( 1 + ( I - 1 )*ABS( INCY ) ) - ELSE - WRITE( NOUT, FMT = 9998 )I, - $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) - END IF - 60 CONTINUE -* - 70 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', - $ 'TED RESULT' ) - 9998 FORMAT( 1X, I7, 2G18.6 ) -* -* End of DMVCH. -* - END - LOGICAL FUNCTION LDE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - DOUBLE PRECISION RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LDE = .TRUE. - GO TO 30 - 20 CONTINUE - LDE = .FALSE. - 30 RETURN -* -* End of LDE. -* - END - LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE', 'SY' or 'SP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - DOUBLE PRECISION AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LDERES = .TRUE. - GO TO 80 - 70 CONTINUE - LDERES = .FALSE. - 80 RETURN -* -* End of LDERES. -* - END - DOUBLE PRECISION FUNCTION DBEG( RESET ) -* -* Generates random numbers uniformly distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, MI -* .. Save statement .. - SAVE I, IC, MI -* .. Intrinsic Functions .. - INTRINSIC DBLE -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - I = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I is bounded between 1 and 999. -* If initial I = 1,2,3,6,7 or 9, the period will be 50. -* If initial I = 4 or 8, the period will be 25. -* If initial I = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I in 6. -* - IC = IC + 1 - 10 I = I*MI - I = I - 1000*( I/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - DBEG = DBLE( I - 500 )/1001.0D0 - RETURN -* -* End of DBEG. -* - END - DOUBLE PRECISION FUNCTION DDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. Executable Statements .. - DDIFF = X - Y - RETURN -* -* End of DDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 2 BLAS -* routines. -* -* XERBLA is an error handler for the Level 2 BLAS routines. -* -* It is called by the Level 2 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/dblat3.dat b/eigen/blas/testing/dblat3.dat deleted file mode 100644 index 5cbc2e6..0000000 --- a/eigen/blas/testing/dblat3.dat +++ /dev/null @@ -1,20 +0,0 @@ -'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. diff --git a/eigen/blas/testing/dblat3.f b/eigen/blas/testing/dblat3.f deleted file mode 100644 index 8d37c74..0000000 --- a/eigen/blas/testing/dblat3.f +++ /dev/null @@ -1,2873 +0,0 @@ -*> \brief \b DBLAT3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM DBLAT3 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the DOUBLE PRECISION Level 3 Blas. -*> -*> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 6 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 20 lines: -*> 'dblat3.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 3 NUMBER OF VALUES OF ALPHA -*> 0.0 1.0 0.7 VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> 0.0 1.0 1.3 VALUES OF BETA -*> DGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. -*> A Set of Level 3 Basic Linear Algebra Subprograms. -*> -*> Technical Memorandum No.88 (Revision 1), Mathematics and -*> Computer Science Division, Argonne National Laboratory, 9700 -*> South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup double_blas_testing -* -* ===================================================================== - PROGRAM DBLAT3 -* -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 6 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - INTEGER NMAX - PARAMETER ( NMAX = 65 ) - INTEGER NIDMAX, NALMAX, NBEMAX - PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), - $ BB( NMAX*NMAX ), BET( NBEMAX ), - $ BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ G( NMAX ), W( 2*NMAX ) - INTEGER IDIM( NIDMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - DOUBLE PRECISION DDIFF - LOGICAL LDE - EXTERNAL DDIFF, LDE -* .. External Subroutines .. - EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHKE, DMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ', - $ 'DSYRK ', 'DSYR2K'/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 220 - END IF - 10 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9984 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 20 I = 1, NSUBS - LTEST( I ) = .FALSE. - 20 CONTINUE - 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT - DO 40 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 50 - 40 CONTINUE - WRITE( NOUT, FMT = 9990 )SNAMET - STOP - 50 LTEST( I ) = LTESTT - GO TO 30 -* - 60 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(ZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of DMMCH using exact data. -* - N = MIN( 32, NMAX ) - DO 100 J = 1, N - DO 90 I = 1, N - AB( I, J ) = MAX( I - J + 1, 0 ) - 90 CONTINUE - AB( J, NMAX + 1 ) = J - AB( 1, NMAX + J ) = J - C( J, 1 ) = ZERO - 100 CONTINUE - DO 110 J = 1, N - CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 110 CONTINUE -* CC holds the exact result. On exit from DMMCH CT holds -* the result computed by DMMCH. - TRANSA = 'N' - TRANSB = 'N' - CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'T' - CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - DO 120 J = 1, N - AB( J, NMAX + 1 ) = N - J + 1 - AB( 1, NMAX + J ) = N - J + 1 - 120 CONTINUE - DO 130 J = 1, N - CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - - $ ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE - TRANSA = 'T' - TRANSB = 'N' - CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'T' - CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LDE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 200 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM -* Test DGEMM, 01. - 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test DSYMM, 02. - 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test DTRMM, 03, DTRSM, 04. - 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, - $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) - GO TO 190 -* Test DSYRK, 05. - 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test DSYR2K, 06. - 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) - GO TO 190 -* - 190 IF( FATAL.AND.SFATAL ) - $ GO TO 210 - END IF - 200 CONTINUE - WRITE( NOUT, FMT = 9986 ) - GO TO 230 -* - 210 CONTINUE - WRITE( NOUT, FMT = 9985 ) - GO TO 230 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9991 ) -* - 230 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9994 FORMAT( ' FOR N ', 9I6 ) - 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) - 9992 FORMAT( ' FOR BETA ', 7F6.1 ) - 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1, - $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', - $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', - $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', - $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9986 FORMAT( /' END OF TESTS' ) - 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of DBLAT3. -* - END - SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests DGEMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX - INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, - $ MA, MB, MS, N, NA, NARGS, NB, NC, NS - LOGICAL NULL, RESET, SAME, TRANA, TRANB - CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DGEMM, DMAKE, DMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. -* - NARGS = 13 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 110 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICA = 1, 3 - TRANSA = ICH( ICA: ICA ) - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' -* - IF( TRANA )THEN - MA = K - NA = M - ELSE - MA = M - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICB = 1, 3 - TRANSB = ICH( ICB: ICB ) - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* - IF( TRANB )THEN - MB = N - NB = K - ELSE - MB = K - NB = N - END IF -* Set LDB to 1 more than minimum value if room. - LDB = MB - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 70 - LBB = LDB*NB -* -* Generate the matrix B. -* - CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, - $ LDB, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, - $ CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANAS = TRANSA - TRANBS = TRANSB - MS = M - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, - $ BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL DGEMM( TRANSA, TRANSB, M, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANSA.EQ.TRANAS - ISAME( 2 ) = TRANSB.EQ.TRANBS - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LDE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LDE( BS, BB, LBB ) - ISAME( 10 ) = LDBS.EQ.LDB - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LDE( CS, CC, LCC ) - ELSE - ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 13 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL DMMCH( TRANSA, TRANSB, M, N, K, - $ ALPHA, A, NMAX, B, NMAX, BETA, - $ C, NMAX, CT, G, CC, LDC, EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, - $ ALPHA, LDA, LDB, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', - $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', - $ 'C,', I3, ').' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK1. -* - END - SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests DSYMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX - INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, - $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, - $ NARGS, NC, NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 SIDE, SIDES, UPLO, UPLOS - CHARACTER*2 ICHS, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DSYMM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHS/'LR'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 90 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 90 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 90 - LBB = LDB*N -* -* Generate the matrix B. -* - CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, - $ ZERO ) -* - DO 80 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' -* - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* -* Generate the symmetric matrix A. -* - CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, - $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 110 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LDE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LDE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LDE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 110 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL DMMCH( 'N', 'N', M, N, M, ALPHA, A, - $ NMAX, B, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL DMMCH( 'N', 'N', M, N, N, ALPHA, B, - $ NMAX, A, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 120 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC -* - 120 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK2. -* - END - SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, - $ B, BB, BS, CT, G, C ) -* -* Tests DTRMM and DTRSM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX - INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, - $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, - $ NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, - $ UPLOS - CHARACTER*2 ICHD, ICHS, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DTRMM, DTRSM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ -* .. Executable Statements .. -* - NARGS = 11 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* Set up zero matrix for DMMCH. - DO 20 J = 1, NMAX - DO 10 I = 1, NMAX - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* - DO 140 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 130 - LBB = LDB*N - NULL = M.LE.0.OR.N.LE.0 -* - DO 120 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 130 - LAA = LDA*NA -* - DO 110 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 100 ICT = 1, 3 - TRANSA = ICHT( ICT: ICT ) -* - DO 90 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - CALL DMAKE( 'TR', UPLO, DIAG, NA, NA, A, - $ NMAX, AA, LDA, RESET, ZERO ) -* -* Generate the matrix B. -* - CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, - $ BB, LDB, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - TRANAS = TRANSA - DIAGS = DIAG - MS = M - NS = N - ALS = ALPHA - DO 30 I = 1, LAA - AS( I ) = AA( I ) - 30 CONTINUE - LDAS = LDA - DO 40 I = 1, LBB - BS( I ) = BB( I ) - 40 CONTINUE - LDBS = LDB -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL DTRMM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL DTRSM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = TRANAS.EQ.TRANSA - ISAME( 4 ) = DIAGS.EQ.DIAG - ISAME( 5 ) = MS.EQ.M - ISAME( 6 ) = NS.EQ.N - ISAME( 7 ) = ALS.EQ.ALPHA - ISAME( 8 ) = LDE( AS, AA, LAA ) - ISAME( 9 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 10 ) = LDE( BS, BB, LBB ) - ELSE - ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS, - $ BB, LDB ) - END IF - ISAME( 11 ) = LDBS.EQ.LDB -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 50 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 50 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MM' )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL DMMCH( TRANSA, 'N', M, N, M, - $ ALPHA, A, NMAX, B, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL DMMCH( 'N', TRANSA, M, N, N, - $ ALPHA, B, NMAX, A, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN -* -* Compute approximation to original -* matrix. -* - DO 70 J = 1, N - DO 60 I = 1, M - C( I, J ) = BB( I + ( J - 1 )* - $ LDB ) - BB( I + ( J - 1 )*LDB ) = ALPHA* - $ B( I, J ) - 60 CONTINUE - 70 CONTINUE -* - IF( LEFT )THEN - CALL DMMCH( TRANSA, 'N', M, N, M, - $ ONE, A, NMAX, C, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - ELSE - CALL DMMCH( 'N', TRANSA, M, N, N, - $ ONE, C, NMAX, A, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - END IF - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 150 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, LDA, LDB -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ') .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK3. -* - END - SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests DSYRK. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, - $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, - $ NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DSYRK -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NTC'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 10 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - BETS = BETA - DO 20 I = 1, LCC - CS( I ) = CC( I ) - 20 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL DSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LDE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = BETS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LDE( CS, CC, LCC ) - ELSE - ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 10 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - JC = 1 - DO 40 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - CALL DMMCH( 'T', 'N', LJ, 1, K, ALPHA, - $ A( 1, JJ ), NMAX, - $ A( 1, J ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL DMMCH( 'N', 'T', LJ, 1, K, ALPHA, - $ A( JJ, 1 ), NMAX, - $ A( J, 1 ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - 40 CONTINUE - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK4. -* - END - SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) -* -* Tests DSYR2K. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), - $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), - $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ G( NMAX ), W( 2*NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, - $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, - $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LDE, LDERES - EXTERNAL LDE, LDERES -* .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DSYR2K -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NTC'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 130 - LCC = LDC*N - NULL = N.LE.0 -* - DO 120 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 110 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*NA -* -* Generate the matrix A. -* - IF( TRAN )THEN - CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, - $ LDA, RESET, ZERO ) - ELSE - CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, - $ RESET, ZERO ) - END IF -* -* Generate the matrix B. -* - LDB = LDA - LBB = LAA - IF( TRAN )THEN - CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), - $ 2*NMAX, BB, LDB, RESET, ZERO ) - ELSE - CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), - $ NMAX, BB, LDB, RESET, ZERO ) - END IF -* - DO 100 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 90 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 80 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BETS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LDE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LDE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BETS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LDE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - JJAB = 1 - JC = 1 - DO 70 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - DO 50 I = 1, K - W( I ) = AB( ( J - 1 )*2*NMAX + K + - $ I ) - W( K + I ) = AB( ( J - 1 )*2*NMAX + - $ I ) - 50 CONTINUE - CALL DMMCH( 'T', 'N', LJ, 1, 2*K, - $ ALPHA, AB( JJAB ), 2*NMAX, - $ W, 2*NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - DO 60 I = 1, K - W( I ) = AB( ( K + I - 1 )*NMAX + - $ J ) - W( K + I ) = AB( ( I - 1 )*NMAX + - $ J ) - 60 CONTINUE - CALL DMMCH( 'N', 'N', LJ, 1, 2*K, - $ ALPHA, AB( JJ ), NMAX, W, - $ 2*NMAX, BETA, C( JJ, J ), - $ NMAX, CT, G, CC( JC ), LDC, - $ EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - IF( TRAN ) - $ JJAB = JJAB + 2*NMAX - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 140 - 70 CONTINUE - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, BETA, LDC -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of DCHK5. -* - END - SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 3 Blas. -* Requires a special version of the error-handling routine XERBLA. -* A, B and C should not need to be defined. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* 3-19-92: Initialize ALPHA and BETA (eca) -* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca) -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Parameters .. - DOUBLE PRECISION ONE, TWO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) -* .. Local Scalars .. - DOUBLE PRECISION ALPHA, BETA -* .. Local Arrays .. - DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, DGEMM, DSYMM, DSYR2K, DSYRK, DTRMM, - $ DTRSM -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. -* -* Initialize ALPHA and BETA. -* - ALPHA = ONE - BETA = TWO -* - GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM - 10 INFOT = 1 - CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL DGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 20 INFOT = 1 - CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 30 INFOT = 1 - CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 40 INFOT = 1 - CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL DTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 50 INFOT = 1 - CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 60 INFOT = 1 - CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 70 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of DCHKE. -* - END - SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, - $ TRANSL ) -* -* Generates values for an M by N matrix A. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'SY' or 'TR'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION ROGUE - PARAMETER ( ROGUE = -1.0D10 ) -* .. Scalar Arguments .. - DOUBLE PRECISION TRANSL - INTEGER LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - DOUBLE PRECISION A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - DOUBLE PRECISION DBEG - EXTERNAL DBEG -* .. Executable Statements .. - GEN = TYPE.EQ.'GE' - SYM = TYPE.EQ.'SY' - TRI = TYPE.EQ.'TR' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - A( I, J ) = DBEG( RESET ) + TRANSL - IF( I.NE.J )THEN -* Set some elements to zero - IF( N.GT.3.AND.J.EQ.N/2 ) - $ A( I, J ) = ZERO - IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 90 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 60 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 70 CONTINUE - DO 80 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - END IF - RETURN -* -* End of DMAKE. -* - END - SUBROUTINE DMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, - $ NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA, EPS, ERR - INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANSA, TRANSB -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ CC( LDCC, * ), CT( * ), G( * ) -* .. Local Scalars .. - DOUBLE PRECISION ERRI - INTEGER I, J, K - LOGICAL TRANA, TRANB -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. Executable Statements .. - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* -* Compute expected result, one column at a time, in CT using data -* in A, B and C. -* Compute gauges in G. -* - DO 120 J = 1, N -* - DO 10 I = 1, M - CT( I ) = ZERO - G( I ) = ZERO - 10 CONTINUE - IF( .NOT.TRANA.AND..NOT.TRANB )THEN - DO 30 K = 1, KK - DO 20 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( K, J ) - G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( TRANA.AND..NOT.TRANB )THEN - DO 50 K = 1, KK - DO 40 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( K, J ) - G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) - 40 CONTINUE - 50 CONTINUE - ELSE IF( .NOT.TRANA.AND.TRANB )THEN - DO 70 K = 1, KK - DO 60 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( J, K ) - G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) - 60 CONTINUE - 70 CONTINUE - ELSE IF( TRANA.AND.TRANB )THEN - DO 90 K = 1, KK - DO 80 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( J, K ) - G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) - 80 CONTINUE - 90 CONTINUE - END IF - DO 100 I = 1, M - CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) - G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) - 100 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 110 I = 1, M - ERRI = ABS( CT( I ) - CC( I, J ) )/EPS - IF( G( I ).NE.ZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.ONE ) - $ GO TO 130 - 110 CONTINUE -* - 120 CONTINUE -* -* If the loop completes, all results are at least half accurate. - GO TO 150 -* -* Report fatal error. -* - 130 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 140 I = 1, M - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) - ELSE - WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) - END IF - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9997 )J -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', - $ 'TED RESULT' ) - 9998 FORMAT( 1X, I7, 2G18.6 ) - 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) -* -* End of DMMCH. -* - END - LOGICAL FUNCTION LDE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - DOUBLE PRECISION RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LDE = .TRUE. - GO TO 30 - 20 CONTINUE - LDE = .FALSE. - 30 RETURN -* -* End of LDE. -* - END - LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE' or 'SY'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - DOUBLE PRECISION AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LDERES = .TRUE. - GO TO 80 - 70 CONTINUE - LDERES = .FALSE. - 80 RETURN -* -* End of LDERES. -* - END - DOUBLE PRECISION FUNCTION DBEG( RESET ) -* -* Generates random numbers uniformly distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, MI -* .. Save statement .. - SAVE I, IC, MI -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - I = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I is bounded between 1 and 999. -* If initial I = 1,2,3,6,7 or 9, the period will be 50. -* If initial I = 4 or 8, the period will be 25. -* If initial I = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I in 6. -* - IC = IC + 1 - 10 I = I*MI - I = I - 1000*( I/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - DBEG = ( I - 500 )/1001.0D0 - RETURN -* -* End of DBEG. -* - END - DOUBLE PRECISION FUNCTION DDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. Executable Statements .. - DDIFF = X - Y - RETURN -* -* End of DDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 3 BLAS -* routines. -* -* XERBLA is an error handler for the Level 3 BLAS routines. -* -* It is called by the Level 3 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/runblastest.sh b/eigen/blas/testing/runblastest.sh deleted file mode 100644 index 4ffaf01..0000000 --- a/eigen/blas/testing/runblastest.sh +++ /dev/null @@ -1,45 +0,0 @@ -#!/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 diff --git a/eigen/blas/testing/sblat1.f b/eigen/blas/testing/sblat1.f deleted file mode 100644 index 6657c26..0000000 --- a/eigen/blas/testing/sblat1.f +++ /dev/null @@ -1,1021 +0,0 @@ -*> \brief \b SBLAT1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM SBLAT1 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the REAL Level 1 BLAS. -*> -*> Based upon the original BLAS test routine together with: -*> F06EAF 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 single_blas_testing -* -* ===================================================================== - PROGRAM SBLAT1 -* -* -- 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, N - LOGICAL PASS -* .. Local Scalars .. - REAL SFAC - INTEGER IC -* .. External Subroutines .. - EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA SFAC/9.765625E-4/ -* .. Executable Statements .. - WRITE (NOUT,99999) - DO 20 IC = 1, 13 - ICASE = IC - CALL HEADER -* -* .. Initialize PASS, INCX, and INCY for a new case. .. -* .. the value 9999 for INCX or INCY will appear in the .. -* .. detailed output, if any, for cases that do not involve .. -* .. these parameters .. -* - PASS = .TRUE. - INCX = 9999 - INCY = 9999 - IF (ICASE.EQ.3 .OR. ICASE.EQ.11) THEN - CALL CHECK0(SFAC) - ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR. - + ICASE.EQ.10) THEN - CALL CHECK1(SFAC) - ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. - + ICASE.EQ.6 .OR. ICASE.EQ.12 .OR. ICASE.EQ.13) THEN - CALL CHECK2(SFAC) - ELSE IF (ICASE.EQ.4) THEN - CALL CHECK3(SFAC) - END IF -* -- Print - IF (PASS) WRITE (NOUT,99998) - 20 CONTINUE - STOP -* -99999 FORMAT (' Real BLAS Test Program Results',/1X) -99998 FORMAT (' ----- PASS -----') - END - SUBROUTINE HEADER -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Arrays .. - CHARACTER*6 L(13) -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA L(1)/' SDOT '/ - DATA L(2)/'SAXPY '/ - DATA L(3)/'SROTG '/ - DATA L(4)/' SROT '/ - DATA L(5)/'SCOPY '/ - DATA L(6)/'SSWAP '/ - DATA L(7)/'SNRM2 '/ - DATA L(8)/'SASUM '/ - DATA L(9)/'SSCAL '/ - DATA L(10)/'ISAMAX'/ - DATA L(11)/'SROTMG'/ - DATA L(12)/'SROTM '/ - DATA L(13)/'SDSDOT'/ -* .. Executable Statements .. - WRITE (NOUT,99999) ICASE, L(ICASE) - RETURN -* -99999 FORMAT (/' Test of subprogram number',I3,12X,A6) - END - SUBROUTINE CHECK0(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - REAL D12, SA, SB, SC, SS - INTEGER I, K -* .. Local Arrays .. - REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8), - + DS1(8), DAB(4,9), DTEMP(9), DTRUE(9,9) -* .. External Subroutines .. - EXTERNAL SROTG, SROTMG, STEST1 -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA DA1/0.3E0, 0.4E0, -0.3E0, -0.4E0, -0.3E0, 0.0E0, - + 0.0E0, 1.0E0/ - DATA DB1/0.4E0, 0.3E0, 0.4E0, 0.3E0, -0.4E0, 0.0E0, - + 1.0E0, 0.0E0/ - DATA DC1/0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.6E0, 1.0E0, - + 0.0E0, 1.0E0/ - DATA DS1/0.8E0, 0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.0E0, - + 1.0E0, 0.0E0/ - DATA DATRUE/0.5E0, 0.5E0, 0.5E0, -0.5E0, -0.5E0, - + 0.0E0, 1.0E0, 1.0E0/ - DATA DBTRUE/0.0E0, 0.6E0, 0.0E0, -0.6E0, 0.0E0, - + 0.0E0, 1.0E0, 0.0E0/ -* INPUT FOR MODIFIED GIVENS - DATA DAB/ .1E0,.3E0,1.2E0,.2E0, - A .7E0, .2E0, .6E0, 4.2E0, - B 0.E0,0.E0,0.E0,0.E0, - C 4.E0, -1.E0, 2.E0, 4.E0, - D 6.E-10, 2.E-2, 1.E5, 10.E0, - E 4.E10, 2.E-2, 1.E-5, 10.E0, - F 2.E-10, 4.E-2, 1.E5, 10.E0, - G 2.E10, 4.E-2, 1.E-5, 10.E0, - H 4.E0, -2.E0, 8.E0, 4.E0 / -* TRUE RESULTS FOR MODIFIED GIVENS - DATA DTRUE/0.E0,0.E0, 1.3E0, .2E0, 0.E0,0.E0,0.E0, .5E0, 0.E0, - A 0.E0,0.E0, 4.5E0, 4.2E0, 1.E0, .5E0, 0.E0,0.E0,0.E0, - B 0.E0,0.E0,0.E0,0.E0, -2.E0, 0.E0,0.E0,0.E0,0.E0, - C 0.E0,0.E0,0.E0, 4.E0, -1.E0, 0.E0,0.E0,0.E0,0.E0, - D 0.E0, 15.E-3, 0.E0, 10.E0, -1.E0, 0.E0, -1.E-4, - E 0.E0, 1.E0, - F 0.E0,0.E0, 6144.E-5, 10.E0, -1.E0, 4096.E0, -1.E6, - G 0.E0, 1.E0, - H 0.E0,0.E0,15.E0,10.E0,-1.E0, 5.E-5, 0.E0,1.E0,0.E0, - I 0.E0,0.E0, 15.E0, 10.E0, -1. E0, 5.E5, -4096.E0, - J 1.E0, 4096.E-6, - K 0.E0,0.E0, 7.E0, 4.E0, 0.E0,0.E0, -.5E0, -.25E0, 0.E0/ -* 4096 = 2 ** 12 - DATA D12 /4096.E0/ - DTRUE(1,1) = 12.E0 / 130.E0 - DTRUE(2,1) = 36.E0 / 130.E0 - DTRUE(7,1) = -1.E0 / 6.E0 - DTRUE(1,2) = 14.E0 / 75.E0 - DTRUE(2,2) = 49.E0 / 75.E0 - DTRUE(9,2) = 1.E0 / 7.E0 - DTRUE(1,5) = 45.E-11 * (D12 * D12) - DTRUE(3,5) = 4.E5 / (3.E0 * D12) - DTRUE(6,5) = 1.E0 / D12 - DTRUE(8,5) = 1.E4 / (3.E0 * D12) - DTRUE(1,6) = 4.E10 / (1.5E0 * D12 * D12) - DTRUE(2,6) = 2.E-2 / 1.5E0 - DTRUE(8,6) = 5.E-7 * D12 - DTRUE(1,7) = 4.E0 / 150.E0 - DTRUE(2,7) = (2.E-10 / 1.5E0) * (D12 * D12) - DTRUE(7,7) = -DTRUE(6,5) - DTRUE(9,7) = 1.E4 / D12 - DTRUE(1,8) = DTRUE(1,7) - DTRUE(2,8) = 2.E10 / (1.5E0 * D12 * D12) - DTRUE(1,9) = 32.E0 / 7.E0 - DTRUE(2,9) = -16.E0 / 7.E0 -* .. Executable Statements .. -* -* Compute true values which cannot be prestored -* in decimal notation -* - DBTRUE(1) = 1.0E0/0.6E0 - DBTRUE(3) = -1.0E0/0.6E0 - DBTRUE(5) = 1.0E0/0.6E0 -* - DO 20 K = 1, 8 -* .. Set N=K for identification in output if any .. - N = K - IF (ICASE.EQ.3) THEN -* .. SROTG .. - IF (K.GT.8) GO TO 40 - SA = DA1(K) - SB = DB1(K) - CALL SROTG(SA,SB,SC,SS) - CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC) - CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC) - CALL STEST1(SC,DC1(K),DC1(K),SFAC) - CALL STEST1(SS,DS1(K),DS1(K),SFAC) - ELSEIF (ICASE.EQ.11) THEN -* .. SROTMG .. - DO I=1,4 - DTEMP(I)= DAB(I,K) - DTEMP(I+4) = 0.0 - END DO - DTEMP(9) = 0.0 - CALL SROTMG(DTEMP(1),DTEMP(2),DTEMP(3),DTEMP(4),DTEMP(5)) - CALL STEST(9,DTEMP,DTRUE(1,K),DTRUE(1,K),SFAC) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK0' - STOP - END IF - 20 CONTINUE - 40 RETURN - END - SUBROUTINE CHECK1(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER I, LEN, NP1 -* .. Local Arrays .. - REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2), - + SA(10), STEMP(1), STRUE(8), SX(8) - INTEGER ITRUE2(5) -* .. External Functions .. - REAL SASUM, SNRM2 - INTEGER ISAMAX - EXTERNAL SASUM, SNRM2, ISAMAX -* .. External Subroutines .. - EXTERNAL ITEST1, SSCAL, STEST, STEST1 -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - DATA SA/0.3E0, -1.0E0, 0.0E0, 1.0E0, 0.3E0, 0.3E0, - + 0.3E0, 0.3E0, 0.3E0, 0.3E0/ - DATA DV/0.1E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, - + 2.0E0, 2.0E0, 0.3E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, - + 3.0E0, 3.0E0, 3.0E0, 0.3E0, -0.4E0, 4.0E0, - + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 0.2E0, - + -0.6E0, 0.3E0, 5.0E0, 5.0E0, 5.0E0, 5.0E0, - + 5.0E0, 0.1E0, -0.3E0, 0.5E0, -0.1E0, 6.0E0, - + 6.0E0, 6.0E0, 6.0E0, 0.1E0, 8.0E0, 8.0E0, 8.0E0, - + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 0.3E0, 9.0E0, 9.0E0, - + 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 0.3E0, 2.0E0, - + -0.4E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, - + 0.2E0, 3.0E0, -0.6E0, 5.0E0, 0.3E0, 2.0E0, - + 2.0E0, 2.0E0, 0.1E0, 4.0E0, -0.3E0, 6.0E0, - + -0.5E0, 7.0E0, -0.1E0, 3.0E0/ - DATA DTRUE1/0.0E0, 0.3E0, 0.5E0, 0.7E0, 0.6E0/ - DATA DTRUE3/0.0E0, 0.3E0, 0.7E0, 1.1E0, 1.0E0/ - DATA DTRUE5/0.10E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, - + 2.0E0, 2.0E0, 2.0E0, -0.3E0, 3.0E0, 3.0E0, - + 3.0E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 0.0E0, 0.0E0, - + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, - + 0.20E0, -0.60E0, 0.30E0, 5.0E0, 5.0E0, 5.0E0, - + 5.0E0, 5.0E0, 0.03E0, -0.09E0, 0.15E0, -0.03E0, - + 6.0E0, 6.0E0, 6.0E0, 6.0E0, 0.10E0, 8.0E0, - + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, - + 0.09E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, - + 9.0E0, 9.0E0, 0.09E0, 2.0E0, -0.12E0, 2.0E0, - + 2.0E0, 2.0E0, 2.0E0, 2.0E0, 0.06E0, 3.0E0, - + -0.18E0, 5.0E0, 0.09E0, 2.0E0, 2.0E0, 2.0E0, - + 0.03E0, 4.0E0, -0.09E0, 6.0E0, -0.15E0, 7.0E0, - + -0.03E0, 3.0E0/ - DATA ITRUE2/0, 1, 2, 2, 3/ -* .. Executable Statements .. - DO 80 INCX = 1, 2 - DO 60 NP1 = 1, 5 - N = NP1 - 1 - LEN = 2*MAX(N,1) -* .. Set vector arguments .. - DO 20 I = 1, LEN - SX(I) = DV(I,NP1,INCX) - 20 CONTINUE -* - IF (ICASE.EQ.7) THEN -* .. SNRM2 .. - STEMP(1) = DTRUE1(NP1) - CALL STEST1(SNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC) - ELSE IF (ICASE.EQ.8) THEN -* .. SASUM .. - STEMP(1) = DTRUE3(NP1) - CALL STEST1(SASUM(N,SX,INCX),STEMP(1),STEMP,SFAC) - ELSE IF (ICASE.EQ.9) THEN -* .. SSCAL .. - CALL SSCAL(N,SA((INCX-1)*5+NP1),SX,INCX) - DO 40 I = 1, LEN - STRUE(I) = DTRUE5(I,NP1,INCX) - 40 CONTINUE - CALL STEST(LEN,SX,STRUE,STRUE,SFAC) - ELSE IF (ICASE.EQ.10) THEN -* .. ISAMAX .. - CALL ITEST1(ISAMAX(N,SX,INCX),ITRUE2(NP1)) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' - STOP - END IF - 60 CONTINUE - 80 CONTINUE - RETURN - END - SUBROUTINE CHECK2(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - REAL SA - INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY, - $ MX, MY -* .. Local Arrays .. - REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), - $ DT8(7,4,4), DX1(7), - $ DY1(7), SSIZE1(4), SSIZE2(14,2), SSIZE3(4), - $ SSIZE(7), STX(7), STY(7), SX(7), SY(7), - $ DPAR(5,4), DT19X(7,4,16),DT19XA(7,4,4), - $ DT19XB(7,4,4), DT19XC(7,4,4),DT19XD(7,4,4), - $ DT19Y(7,4,16), DT19YA(7,4,4),DT19YB(7,4,4), - $ DT19YC(7,4,4), DT19YD(7,4,4), DTEMP(5), - $ ST7B(4,4) - INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) -* .. External Functions .. - REAL SDOT, SDSDOT - EXTERNAL SDOT, SDSDOT -* .. External Subroutines .. - EXTERNAL SAXPY, SCOPY, SROTM, SSWAP, STEST, STEST1 -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - EQUIVALENCE (DT19X(1,1,1),DT19XA(1,1,1)),(DT19X(1,1,5), - A DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)), - B (DT19X(1,1,13),DT19XD(1,1,1)) - EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5), - A DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)), - B (DT19Y(1,1,13),DT19YD(1,1,1)) - - DATA SA/0.3E0/ - 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 DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, - + -0.4E0/ - DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, - + 0.8E0/ - DATA DT7/0.0E0, 0.30E0, 0.21E0, 0.62E0, 0.0E0, - + 0.30E0, -0.07E0, 0.85E0, 0.0E0, 0.30E0, -0.79E0, - + -0.74E0, 0.0E0, 0.30E0, 0.33E0, 1.27E0/ - DATA ST7B/ .1, .4, .31, .72, .1, .4, .03, .95, - + .1, .4, -.69, -.64, .1, .4, .43, 1.37/ - DATA DT8/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.15E0, - + 0.94E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.68E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.35E0, -0.9E0, 0.48E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.38E0, -0.9E0, 0.57E0, 0.7E0, -0.75E0, - + 0.2E0, 0.98E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.68E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.35E0, -0.72E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.38E0, - + -0.63E0, 0.15E0, 0.88E0, 0.0E0, 0.0E0, 0.0E0, - + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.7E0, - + -0.75E0, 0.2E0, 1.04E0/ - DATA DT10X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.5E0, -0.9E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.5E0, -0.9E0, 0.3E0, 0.7E0, - + 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.3E0, 0.1E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.8E0, 0.1E0, -0.6E0, - + 0.8E0, 0.3E0, -0.3E0, 0.5E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.9E0, - + 0.1E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, - + 0.1E0, 0.3E0, 0.8E0, -0.9E0, -0.3E0, 0.5E0, - + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.5E0, 0.3E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.5E0, 0.3E0, -0.6E0, 0.8E0, 0.0E0, 0.0E0, - + 0.0E0/ - DATA DT10Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, 0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.0E0, - + 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, -0.5E0, -0.9E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, -0.4E0, -0.9E0, 0.9E0, - + 0.7E0, -0.5E0, 0.2E0, 0.6E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.5E0, - + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + -0.4E0, 0.9E0, -0.5E0, 0.6E0, 0.0E0, 0.0E0, - + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.7E0, - + -0.5E0, 0.2E0, 0.8E0/ - DATA SSIZE1/0.0E0, 0.3E0, 1.6E0, 3.2E0/ - DATA SSIZE2/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 SSIZE3/ .1, .4, 1.7, 3.3 / -* -* FOR DROTM -* - DATA DPAR/-2.E0, 0.E0,0.E0,0.E0,0.E0, - A -1.E0, 2.E0, -3.E0, -4.E0, 5.E0, - B 0.E0, 0.E0, 2.E0, -3.E0, 0.E0, - C 1.E0, 5.E0, 2.E0, 0.E0, -4.E0/ -* TRUE X RESULTS F0R ROTATIONS DROTM - DATA DT19XA/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .6E0, .1E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - I -.8E0, 3.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - J -.9E0, 2.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - K 3.5E0, -.4E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - L .6E0, .1E0, -.5E0, .8E0, 0.E0,0.E0,0.E0, - M -.8E0, 3.8E0, -2.2E0, -1.2E0, 0.E0,0.E0,0.E0, - N -.9E0, 2.8E0, -1.4E0, -1.3E0, 0.E0,0.E0,0.E0, - O 3.5E0, -.4E0, -2.2E0, 4.7E0, 0.E0,0.E0,0.E0/ -* - DATA DT19XB/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .6E0, .1E0, -.5E0, 0.E0,0.E0,0.E0,0.E0, - I 0.E0, .1E0, -3.0E0, 0.E0,0.E0,0.E0,0.E0, - J -.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0, - K 3.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0, - L .6E0, .1E0, -.5E0, .8E0, .9E0, -.3E0, -.4E0, - M -2.0E0, .1E0, 1.4E0, .8E0, .6E0, -.3E0, -2.8E0, - N -1.8E0, .1E0, 1.3E0, .8E0, 0.E0, -.3E0, -1.9E0, - O 3.8E0, .1E0, -3.1E0, .8E0, 4.8E0, -.3E0, -1.5E0 / -* - DATA DT19XC/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .6E0, .1E0, -.5E0, 0.E0,0.E0,0.E0,0.E0, - I 4.8E0, .1E0, -3.0E0, 0.E0,0.E0,0.E0,0.E0, - J 3.3E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0, - K 2.1E0, .1E0, -2.0E0, 0.E0,0.E0,0.E0,0.E0, - L .6E0, .1E0, -.5E0, .8E0, .9E0, -.3E0, -.4E0, - M -1.6E0, .1E0, -2.2E0, .8E0, 5.4E0, -.3E0, -2.8E0, - N -1.5E0, .1E0, -1.4E0, .8E0, 3.6E0, -.3E0, -1.9E0, - O 3.7E0, .1E0, -2.2E0, .8E0, 3.6E0, -.3E0, -1.5E0 / -* - DATA DT19XD/.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .6E0, .1E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - I -.8E0, -1.0E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - J -.9E0, -.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - K 3.5E0, .8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - L .6E0, .1E0, -.5E0, .8E0, 0.E0,0.E0,0.E0, - M -.8E0, -1.0E0, 1.4E0, -1.6E0, 0.E0,0.E0,0.E0, - N -.9E0, -.8E0, 1.3E0, -1.6E0, 0.E0,0.E0,0.E0, - O 3.5E0, .8E0, -3.1E0, 4.8E0, 0.E0,0.E0,0.E0/ -* TRUE Y RESULTS FOR ROTATIONS DROTM - DATA DT19YA/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .5E0, -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - I .7E0, -4.8E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - J 1.7E0, -.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - K -2.6E0, 3.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - L .5E0, -.9E0, .3E0, .7E0, 0.E0,0.E0,0.E0, - M .7E0, -4.8E0, 3.0E0, 1.1E0, 0.E0,0.E0,0.E0, - N 1.7E0, -.7E0, -.7E0, 2.3E0, 0.E0,0.E0,0.E0, - O -2.6E0, 3.5E0, -.7E0, -3.6E0, 0.E0,0.E0,0.E0/ -* - DATA DT19YB/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .5E0, -.9E0, .3E0, 0.E0,0.E0,0.E0,0.E0, - I 4.0E0, -.9E0, -.3E0, 0.E0,0.E0,0.E0,0.E0, - J -.5E0, -.9E0, 1.5E0, 0.E0,0.E0,0.E0,0.E0, - K -1.5E0, -.9E0, -1.8E0, 0.E0,0.E0,0.E0,0.E0, - L .5E0, -.9E0, .3E0, .7E0, -.6E0, .2E0, .8E0, - M 3.7E0, -.9E0, -1.2E0, .7E0, -1.5E0, .2E0, 2.2E0, - N -.3E0, -.9E0, 2.1E0, .7E0, -1.6E0, .2E0, 2.0E0, - O -1.6E0, -.9E0, -2.1E0, .7E0, 2.9E0, .2E0, -3.8E0 / -* - DATA DT19YC/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .5E0, -.9E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - I 4.0E0, -6.3E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - J -.5E0, .3E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - K -1.5E0, 3.0E0, 0.E0,0.E0,0.E0,0.E0,0.E0, - L .5E0, -.9E0, .3E0, .7E0, 0.E0,0.E0,0.E0, - M 3.7E0, -7.2E0, 3.0E0, 1.7E0, 0.E0,0.E0,0.E0, - N -.3E0, .9E0, -.7E0, 1.9E0, 0.E0,0.E0,0.E0, - O -1.6E0, 2.7E0, -.7E0, -3.4E0, 0.E0,0.E0,0.E0/ -* - DATA DT19YD/.5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - A .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - B .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - C .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - D .5E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - E .7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - F 1.7E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - G -2.6E0, 0.E0,0.E0,0.E0,0.E0,0.E0,0.E0, - H .5E0, -.9E0, .3E0, 0.E0,0.E0,0.E0,0.E0, - I .7E0, -.9E0, 1.2E0, 0.E0,0.E0,0.E0,0.E0, - J 1.7E0, -.9E0, .5E0, 0.E0,0.E0,0.E0,0.E0, - K -2.6E0, -.9E0, -1.3E0, 0.E0,0.E0,0.E0,0.E0, - L .5E0, -.9E0, .3E0, .7E0, -.6E0, .2E0, .8E0, - M .7E0, -.9E0, 1.2E0, .7E0, -1.5E0, .2E0, 1.6E0, - N 1.7E0, -.9E0, .5E0, .7E0, -1.6E0, .2E0, 2.4E0, - O -2.6E0, -.9E0, -1.3E0, .7E0, 2.9E0, .2E0, -4.0E0 / -* -* .. Executable Statements .. -* - DO 120 KI = 1, 4 - INCX = INCXS(KI) - INCY = INCYS(KI) - MX = ABS(INCX) - MY = ABS(INCY) -* - DO 100 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 - SX(I) = DX1(I) - SY(I) = DY1(I) - 20 CONTINUE -* - IF (ICASE.EQ.1) THEN -* .. SDOT .. - CALL STEST1(SDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN) - + ,SFAC) - ELSE IF (ICASE.EQ.2) THEN -* .. SAXPY .. - CALL SAXPY(N,SA,SX,INCX,SY,INCY) - DO 40 J = 1, LENY - STY(J) = DT8(J,KN,KI) - 40 CONTINUE - CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) - ELSE IF (ICASE.EQ.5) THEN -* .. SCOPY .. - DO 60 I = 1, 7 - STY(I) = DT10Y(I,KN,KI) - 60 CONTINUE - CALL SCOPY(N,SX,INCX,SY,INCY) - CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) - ELSE IF (ICASE.EQ.6) THEN -* .. SSWAP .. - CALL SSWAP(N,SX,INCX,SY,INCY) - DO 80 I = 1, 7 - STX(I) = DT10X(I,KN,KI) - STY(I) = DT10Y(I,KN,KI) - 80 CONTINUE - CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0E0) - CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) - ELSEIF (ICASE.EQ.12) THEN -* .. SROTM .. - KNI=KN+4*(KI-1) - DO KPAR=1,4 - DO I=1,7 - SX(I) = DX1(I) - SY(I) = DY1(I) - STX(I)= DT19X(I,KPAR,KNI) - STY(I)= DT19Y(I,KPAR,KNI) - END DO -* - DO I=1,5 - DTEMP(I) = DPAR(I,KPAR) - END DO -* - DO I=1,LENX - SSIZE(I)=STX(I) - END DO -* SEE REMARK ABOVE ABOUT DT11X(1,2,7) -* AND DT11X(5,3,8). - IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7)) - $ SSIZE(1) = 2.4E0 - IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8)) - $ SSIZE(5) = 1.8E0 -* - CALL SROTM(N,SX,INCX,SY,INCY,DTEMP) - CALL STEST(LENX,SX,STX,SSIZE,SFAC) - CALL STEST(LENY,SY,STY,STY,SFAC) - END DO - ELSEIF (ICASE.EQ.13) THEN -* .. SDSROT .. - CALL STEST1 (SDSDOT(N,.1,SX,INCX,SY,INCY), - $ ST7B(KN,KI),SSIZE3(KN),SFAC) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' - STOP - END IF - 100 CONTINUE - 120 CONTINUE - RETURN - END - SUBROUTINE CHECK3(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - REAL SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, N - LOGICAL PASS -* .. Local Scalars .. - REAL SC, SS - INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY -* .. Local Arrays .. - REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4), - + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5), - + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5), - + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7), - + SY(7) - INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11), - + MWPINY(11), MWPN(11), NS(4) -* .. External Subroutines .. - EXTERNAL SROT, STEST -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, PASS -* .. Data statements .. - 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 DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, - + -0.4E0/ - DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, - + 0.8E0/ - DATA SC, SS/0.8E0, 0.6E0/ - DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0, - + 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0, - + -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0, - + -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0, - + 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0, - + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0, - + 0.0E0, 0.0E0, 0.0E0/ - DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0, - + 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, - + -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0, - + 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0, - + 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0, - + -0.18E0, 0.2E0, 0.16E0/ - DATA SSIZE2/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/ -* .. 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) -* - IF (ICASE.EQ.4) THEN -* .. SROT .. - DO 20 I = 1, 7 - SX(I) = DX1(I) - SY(I) = DY1(I) - STX(I) = DT9X(I,KN,KI) - STY(I) = DT9Y(I,KN,KI) - 20 CONTINUE - CALL SROT(N,SX,INCX,SY,INCY,SC,SS) - CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC) - CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK3' - STOP - END IF - 40 CONTINUE - 60 CONTINUE -* - MWPC(1) = 1 - DO 80 I = 2, 11 - MWPC(I) = 0 - 80 CONTINUE - MWPS(1) = 0 - DO 100 I = 2, 6 - MWPS(I) = 1 - 100 CONTINUE - DO 120 I = 7, 11 - MWPS(I) = -1 - 120 CONTINUE - MWPINX(1) = 1 - MWPINX(2) = 1 - MWPINX(3) = 1 - MWPINX(4) = -1 - MWPINX(5) = 1 - MWPINX(6) = -1 - MWPINX(7) = 1 - MWPINX(8) = 1 - MWPINX(9) = -1 - MWPINX(10) = 1 - MWPINX(11) = -1 - MWPINY(1) = 1 - MWPINY(2) = 1 - MWPINY(3) = -1 - MWPINY(4) = -1 - MWPINY(5) = 2 - MWPINY(6) = 1 - MWPINY(7) = 1 - MWPINY(8) = -1 - MWPINY(9) = -1 - MWPINY(10) = 2 - MWPINY(11) = 1 - DO 140 I = 1, 11 - MWPN(I) = 5 - 140 CONTINUE - MWPN(5) = 3 - MWPN(10) = 3 - DO 160 I = 1, 5 - MWPX(I) = I - MWPY(I) = I - MWPTX(1,I) = I - MWPTY(1,I) = I - MWPTX(2,I) = I - MWPTY(2,I) = -I - MWPTX(3,I) = 6 - I - MWPTY(3,I) = I - 6 - MWPTX(4,I) = I - MWPTY(4,I) = -I - MWPTX(6,I) = 6 - I - MWPTY(6,I) = I - 6 - MWPTX(7,I) = -I - MWPTY(7,I) = I - MWPTX(8,I) = I - 6 - MWPTY(8,I) = 6 - I - MWPTX(9,I) = -I - MWPTY(9,I) = I - MWPTX(11,I) = I - 6 - MWPTY(11,I) = 6 - I - 160 CONTINUE - MWPTX(5,1) = 1 - MWPTX(5,2) = 3 - MWPTX(5,3) = 5 - MWPTX(5,4) = 4 - MWPTX(5,5) = 5 - MWPTY(5,1) = -1 - MWPTY(5,2) = 2 - MWPTY(5,3) = -2 - MWPTY(5,4) = 4 - MWPTY(5,5) = -3 - MWPTX(10,1) = -1 - MWPTX(10,2) = -3 - MWPTX(10,3) = -5 - MWPTX(10,4) = 4 - MWPTX(10,5) = 5 - MWPTY(10,1) = 1 - MWPTY(10,2) = 2 - MWPTY(10,3) = 2 - MWPTY(10,4) = 4 - MWPTY(10,5) = 3 - DO 200 I = 1, 11 - INCX = MWPINX(I) - INCY = MWPINY(I) - DO 180 K = 1, 5 - COPYX(K) = MWPX(K) - COPYY(K) = MWPY(K) - MWPSTX(K) = MWPTX(I,K) - MWPSTY(K) = MWPTY(I,K) - 180 CONTINUE - CALL SROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I)) - CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC) - CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC) - 200 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, 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, 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, I, SCOMP(I), - + STRUE(I), SD, SSIZE(I) - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY I ', - + ' COMP(I) TRUE(I) DIFFERENCE', - + ' SIZE(I)',/1X) -99997 FORMAT (1X,I4,I3,2I5,I3,2E36.8,2E12.4) - END - SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) -* ************************* STEST1 ***************************** -* -* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN -* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE -* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. -* -* C.L. LAWSON, JPL, 1978 DEC 6 -* -* .. Scalar Arguments .. - REAL SCOMP1, SFAC, STRUE1 -* .. Array Arguments .. - REAL SSIZE(*) -* .. Local Arrays .. - REAL SCOMP(1), STRUE(1) -* .. External Subroutines .. - EXTERNAL STEST -* .. Executable Statements .. -* - SCOMP(1) = SCOMP1 - STRUE(1) = STRUE1 - CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) -* - RETURN - END - REAL FUNCTION SDIFF(SA,SB) -* ********************************* SDIFF ************************** -* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 -* -* .. Scalar Arguments .. - REAL SA, SB -* .. Executable Statements .. - SDIFF = SA - SB - RETURN - END - SUBROUTINE 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, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER ID -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, 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, ICOMP, ITRUE, ID - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY ', - + ' COMP TRUE DIFFERENCE', - + /1X) -99997 FORMAT (1X,I4,I3,2I5,2I36,I12) - END diff --git a/eigen/blas/testing/sblat2.dat b/eigen/blas/testing/sblat2.dat deleted file mode 100644 index f537d30..0000000 --- a/eigen/blas/testing/sblat2.dat +++ /dev/null @@ -1,34 +0,0 @@ -'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. diff --git a/eigen/blas/testing/sblat2.f b/eigen/blas/testing/sblat2.f deleted file mode 100644 index 71605ed..0000000 --- a/eigen/blas/testing/sblat2.f +++ /dev/null @@ -1,3176 +0,0 @@ -*> \brief \b SBLAT2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM SBLAT2 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the REAL Level 2 Blas. -*> -*> The program must be driven by a short data file. The first 18 records -*> of the file are read using list-directed input, the last 16 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 34 lines: -*> 'sblat2.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 4 NUMBER OF VALUES OF K -*> 0 1 2 4 VALUES OF K -*> 4 NUMBER OF VALUES OF INCX AND INCY -*> 1 2 -1 -2 VALUES OF INCX AND INCY -*> 3 NUMBER OF VALUES OF ALPHA -*> 0.0 1.0 0.7 VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> 0.0 1.0 0.9 VALUES OF BETA -*> SGEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> SGBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYMV T PUT F FOR NO TEST. SAME COLUMNS. -*> SSBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> SSPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> STRMV T PUT F FOR NO TEST. SAME COLUMNS. -*> STBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> STPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> STRSV T PUT F FOR NO TEST. SAME COLUMNS. -*> STBSV T PUT F FOR NO TEST. SAME COLUMNS. -*> STPSV T PUT F FOR NO TEST. SAME COLUMNS. -*> SGER T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYR T PUT F FOR NO TEST. SAME COLUMNS. -*> SSPR T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. -*> An extended set of Fortran Basic Linear Algebra Subprograms. -*> -*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics -*> and Computer Science Division, Argonne National Laboratory, -*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> Or -*> -*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms -*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford -*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st -*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. -*> -*> -*> -- Written on 10-August-1987. -*> Richard Hanson, Sandia National Labs. -*> Jeremy Du Croz, NAG Central Office. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup single_blas_testing -* -* ===================================================================== - PROGRAM SBLAT2 -* -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 16 ) - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) - INTEGER NMAX, INCMAX - PARAMETER ( NMAX = 65, INCMAX = 2 ) - INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX - PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, - $ NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, - $ NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANS - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), - $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( 2*NMAX ) - INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - REAL SDIFF - LOGICAL LSE - EXTERNAL SDIFF, LSE -* .. External Subroutines .. - EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6, - $ SCHKE, SMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ', - $ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ', - $ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ', - $ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 230 - END IF - 10 CONTINUE -* Values of K - READ( NIN, FMT = * )NKB - IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN - WRITE( NOUT, FMT = 9997 )'K', NKBMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) - DO 20 I = 1, NKB - IF( KB( I ).LT.0 )THEN - WRITE( NOUT, FMT = 9995 ) - GO TO 230 - END IF - 20 CONTINUE -* Values of INCX and INCY - READ( NIN, FMT = * )NINC - IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN - WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) - DO 30 I = 1, NINC - IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN - WRITE( NOUT, FMT = 9994 )INCMAX - GO TO 230 - END IF - 30 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9993 ) - WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) - WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) - WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9980 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 40 I = 1, NSUBS - LTEST( I ) = .FALSE. - 40 CONTINUE - 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT - DO 60 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 70 - 60 CONTINUE - WRITE( NOUT, FMT = 9986 )SNAMET - STOP - 70 LTEST( I ) = LTESTT - GO TO 50 -* - 80 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(ZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of SMVCH using exact data. -* - N = MIN( 32, NMAX ) - DO 120 J = 1, N - DO 110 I = 1, N - A( I, J ) = MAX( I - J + 1, 0 ) - 110 CONTINUE - X( J ) = J - Y( J ) = ZERO - 120 CONTINUE - DO 130 J = 1, N - YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE -* YY holds the exact result. On exit from SMVCH YT holds -* the result computed by SMVCH. - TRANS = 'N' - CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF - TRANS = 'T' - CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 210 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 140, 150, 150, 150, 160, 160, - $ 160, 160, 160, 160, 170, 180, 180, - $ 190, 190 )ISNUM -* Test SGEMV, 01, and SGBMV, 02. - 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. - 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test STRMV, 06, STBMV, 07, STPMV, 08, -* STRSV, 09, STBSV, 10, and STPSV, 11. - 160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) - GO TO 200 -* Test SGER, 12. - 170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test SSYR, 13, and SSPR, 14. - 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test SSYR2, 15, and SSPR2, 16. - 190 CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) -* - 200 IF( FATAL.AND.SFATAL ) - $ GO TO 220 - END IF - 210 CONTINUE - WRITE( NOUT, FMT = 9982 ) - GO TO 240 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9981 ) - GO TO 240 -* - 230 CONTINUE - WRITE( NOUT, FMT = 9987 ) -* - 240 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) - 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', - $ I2 ) - 9993 FORMAT( ' TESTS OF THE REAL LEVEL 2 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9992 FORMAT( ' FOR N ', 9I6 ) - 9991 FORMAT( ' FOR K ', 7I6 ) - 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) - 9989 FORMAT( ' FOR ALPHA ', 7F6.1 ) - 9988 FORMAT( ' FOR BETA ', 7F6.1 ) - 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9985 FORMAT( ' ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' SMVCH WAS CALLED WITH TRANS = ', A1, - $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / - $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' - $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9982 FORMAT( /' END OF TESTS' ) - 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of SBLAT2. -* - END - SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests SGEMV and SGBMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF - PARAMETER ( ZERO = 0.0, HALF = 0.5 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, - $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, - $ NL, NS - LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN - CHARACTER*1 TRANS, TRANSS - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SGBMV, SGEMV, SMAKE, SMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 11 - ELSE IF( BANDED )THEN - NARGS = 13 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IKU = 1, NK - IF( BANDED )THEN - KU = KB( IKU ) - KL = MAX( KU - 1, 0 ) - ELSE - KU = N - 1 - KL = M - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = KL + KU + 1 - ELSE - LDA = M - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, - $ LDA, KL, KU, RESET, TRANSL ) -* - DO 90 IC = 1, 3 - TRANS = ICH( IC: IC ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' -* - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*NL -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, - $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) - IF( NL.GT.1 )THEN - X( NL/2 ) = ZERO - XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*ML -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL SMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, - $ YY, ABS( INCY ), 0, ML - 1, - $ RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANSS = TRANS - MS = M - NS = N - KLS = KL - KUS = KU - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ TRANS, M, N, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL SGEMV( TRANS, M, N, ALPHA, AA, - $ LDA, XX, INCX, BETA, YY, - $ INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANS, M, N, KL, KU, ALPHA, LDA, - $ INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL SGBMV( TRANS, M, N, KL, KU, ALPHA, - $ AA, LDA, XX, INCX, BETA, - $ YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 130 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANS.EQ.TRANSS - ISAME( 2 ) = MS.EQ.M - ISAME( 3 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LSE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LSE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LSERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 4 ) = KLS.EQ.KL - ISAME( 5 ) = KUS.EQ.KU - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LSE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LSE( XS, XX, LX ) - ISAME( 10 ) = INCXS.EQ.INCX - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 12 ) = LSERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 13 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 130 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL SMVCH( TRANS, M, N, ALPHA, A, - $ NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 130 - ELSE -* Avoid repeating tests with M.le.0 or -* N.le.0. - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 140 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, - $ ALPHA, LDA, INCX, BETA, INCY - END IF -* - 140 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, - $ ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK1. -* - END - SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests SSYMV, SSBMV and SSPMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF - PARAMETER ( ZERO = 0.0, HALF = 0.5 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, - $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, SSBMV, SSPMV, SSYMV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 10 - ELSE IF( BANDED )THEN - NARGS = 11 - ELSE IF( PACKED )THEN - NARGS = 9 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, - $ LDA, K, K, RESET, TRANSL ) -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - UPLOS = UPLO - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL SSYMV( UPLO, N, ALPHA, AA, LDA, XX, - $ INCX, BETA, YY, INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, N, K, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL SSBMV( UPLO, N, K, ALPHA, AA, LDA, - $ XX, INCX, BETA, YY, INCY ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, N, ALPHA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL SSPMV( UPLO, N, ALPHA, AA, XX, INCX, - $ BETA, YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( AS, AA, LAA ) - ISAME( 5 ) = LDAS.EQ.LDA - ISAME( 6 ) = LSE( XS, XX, LX ) - ISAME( 7 ) = INCXS.EQ.INCX - ISAME( 8 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 9 ) = LSERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 10 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 3 ) = KS.EQ.K - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LSE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LSE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LSERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( PACKED )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( AS, AA, LAA ) - ISAME( 5 ) = LSE( XS, XX, LX ) - ISAME( 6 ) = INCXS.EQ.INCX - ISAME( 7 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 8 ) = LSE( YS, YY, LY ) - ELSE - ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 9 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL SMVCH( 'N', N, N, ALPHA, A, NMAX, X, - $ INCX, BETA, Y, INCY, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0 - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, - $ BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ BETA, INCY - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP', - $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, - $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, - $ ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', - $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK2. -* - END - SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) -* -* Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XT( NMAX ), - $ XX( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - REAL ERR, ERRMAX, TRANSL - INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, - $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHD, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, STBMV, STBSV, STPMV, STPSV, - $ STRMV, STRSV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'R' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 8 - ELSE IF( BANDED )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 7 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* Set up zero vector for SMVCH. - DO 10 I = 1, NMAX - Z( I ) = ZERO - 10 CONTINUE -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) -* - DO 70 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, - $ NMAX, AA, LDA, K, K, RESET, TRANSL ) -* - DO 60 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, - $ TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - DIAGS = DIAG - NS = N - KS = K - DO 20 I = 1, LAA - AS( I ) = AA( I ) - 20 CONTINUE - LDAS = LDA - DO 30 I = 1, LX - XS( I ) = XX( I ) - 30 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL STRMV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL STBMV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL STPMV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL STRSV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL STBSV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL STPSV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = TRANS.EQ.TRANSS - ISAME( 3 ) = DIAG.EQ.DIAGS - ISAME( 4 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 5 ) = LSE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 7 ) = LSE( XS, XX, LX ) - ELSE - ISAME( 7 ) = LSERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 8 ) = INCXS.EQ.INCX - ELSE IF( BANDED )THEN - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = LSE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 8 ) = LSE( XS, XX, LX ) - ELSE - ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 9 ) = INCXS.EQ.INCX - ELSE IF( PACKED )THEN - ISAME( 5 ) = LSE( AS, AA, LAA ) - IF( NULL )THEN - ISAME( 6 ) = LSE( XS, XX, LX ) - ELSE - ISAME( 6 ) = LSERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 7 ) = INCXS.EQ.INCX - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MV' )THEN -* -* Check the result. -* - CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, - $ INCX, ZERO, Z, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN -* -* Compute approximation to original vector. -* - DO 50 I = 1, N - Z( I ) = XX( 1 + ( I - 1 )* - $ ABS( INCX ) ) - XX( 1 + ( I - 1 )*ABS( INCX ) ) - $ = X( I ) - 50 CONTINUE - CALL SMVCH( TRANS, N, N, ONE, A, NMAX, Z, - $ INCX, ZERO, X, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .FALSE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0. - GO TO 110 - END IF -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, - $ INCX - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, - $ LDA, INCX - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', - $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), - $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', - $ I3, ', X,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK3. -* - END - SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests SGER. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - REAL ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, - $ NC, ND, NS - LOGICAL NULL, RESET, SAME -* .. Local Arrays .. - REAL W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SGER, SMAKE, SMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* Define the number of arguments. - NARGS = 9 -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* -* Set LDA to 1 more than minimum value if room. - LDA = M - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 100 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*M -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), - $ 0, M - 1, RESET, TRANSL ) - IF( M.GT.1 )THEN - X( M/2 ) = ZERO - XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO - END IF -* - DO 90 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, - $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL SGER( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 140 - END IF -* -* See what data changed inside subroutine. -* - ISAME( 1 ) = MS.EQ.M - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LSE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LSE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LSERES( 'GE', ' ', M, N, AS, AA, - $ LDA ) - END IF - ISAME( 9 ) = LDAS.EQ.LDA -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 140 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, M - Z( I ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, M - Z( I ) = X( M - I + 1 ) - 60 CONTINUE - END IF - DO 70 J = 1, N - IF( INCY.GT.0 )THEN - W( 1 ) = Y( J ) - ELSE - W( 1 ) = Y( N - J + 1 ) - END IF - CALL SMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, - $ ONE, A( 1, J ), 1, YT, G, - $ AA( 1 + ( J - 1 )*LDA ), EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 130 - 70 CONTINUE - ELSE -* Avoid repeating tests with M.le.0 or N.le.0. - GO TO 110 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 150 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 140 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2, - $ ', Y,', I2, ', A,', I3, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK4. -* - END - SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests SSYR and SSPR. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - REAL ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, - $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - REAL W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, SSPR, SSYR -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 7 - ELSE IF( PACKED )THEN - NARGS = 6 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, - $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, LDA - IF( REWI ) - $ REWIND NTRA - CALL SSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX - IF( REWI ) - $ REWIND NTRA - CALL SSPR( UPLO, N, ALPHA, XX, INCX, AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - IF( NULL )THEN - ISAME( 6 ) = LSE( AS, AA, LAA ) - ELSE - ISAME( 6 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N, AS, - $ AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 7 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 40 I = 1, N - Z( I ) = X( I ) - 40 CONTINUE - ELSE - DO 50 I = 1, N - Z( I ) = X( N - I + 1 ) - 50 CONTINUE - END IF - JA = 1 - DO 60 J = 1, N - W( 1 ) = Z( J ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL SMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, - $ 1, ONE, A( JJ, J ), 1, YT, G, - $ AA( JA ), EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 110 - 60 CONTINUE - ELSE -* Avoid repeating tests if N.le.0. - IF( N.LE.0 ) - $ GO TO 100 - END IF -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK5. -* - END - SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests SSYR2 and SSPR2. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - REAL ALPHA, ALS, ERR, ERRMAX, TRANSL - INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, - $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - REAL W( 2 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, SSPR2, SSYR2 -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 8 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 140 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 140 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 130 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 120 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 110 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 100 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, - $ NMAX, AA, LDA, N - 1, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL SSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY - IF( REWI ) - $ REWIND NTRA - CALL SSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 160 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LSE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LSE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LSE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N, - $ AS, AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 9 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 160 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, N - Z( I, 1 ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - Z( I, 1 ) = X( N - I + 1 ) - 60 CONTINUE - END IF - IF( INCY.GT.0 )THEN - DO 70 I = 1, N - Z( I, 2 ) = Y( I ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - Z( I, 2 ) = Y( N - I + 1 ) - 80 CONTINUE - END IF - JA = 1 - DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) - W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL SMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), - $ NMAX, W, 1, ONE, A( JJ, J ), 1, - $ YT, G, AA( JA ), EPS, ERR, FATAL, - $ NOUT, .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 150 - 90 CONTINUE - ELSE -* Avoid repeating tests with N.le.0. - IF( N.LE.0 ) - $ GO TO 140 - END IF -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 170 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 160 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ INCY, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY - END IF -* - 170 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', Y,', I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', Y,', I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK6. -* - END - SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 2 Blas. -* Requires a special version of the error-handling routine XERBLA. -* ALPHA, BETA, A, X and Y should not need to be defined. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Local Scalars .. - REAL ALPHA, BETA -* .. Local Arrays .. - REAL A( 1, 1 ), X( 1 ), Y( 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, SGBMV, SGEMV, SGER, SSBMV, SSPMV, SSPR, - $ SSPR2, SSYMV, SSYR, SSYR2, STBMV, STBSV, STPMV, - $ STPSV, STRMV, STRSV -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90, 100, 110, 120, 130, 140, 150, - $ 160 )ISNUM - 10 INFOT = 1 - CALL SGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL SGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 20 INFOT = 1 - CALL SGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 30 INFOT = 1 - CALL SSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 40 INFOT = 1 - CALL SSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL SSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 50 INFOT = 1 - CALL SSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL SSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 60 INFOT = 1 - CALL STRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL STRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 70 INFOT = 1 - CALL STBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 80 INFOT = 1 - CALL STPMV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STPMV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STPMV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STPMV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STPMV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 90 INFOT = 1 - CALL STRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL STRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 100 INFOT = 1 - CALL STBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 110 INFOT = 1 - CALL STPSV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STPSV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STPSV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STPSV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STPSV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 120 INFOT = 1 - CALL SGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 130 INFOT = 1 - CALL SSYR( '/', 0, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYR( 'U', -1, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSYR( 'U', 0, ALPHA, X, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR( 'U', 2, ALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 140 INFOT = 1 - CALL SSPR( '/', 0, ALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSPR( 'U', -1, ALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSPR( 'U', 0, ALPHA, X, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 150 INFOT = 1 - CALL SSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 - 160 INFOT = 1 - CALL SSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 170 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of SCHKE. -* - END - SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, - $ KU, RESET, TRANSL ) -* -* Generates values for an M by N matrix A within the bandwidth -* defined by KL and KU. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) - REAL ROGUE - PARAMETER ( ROGUE = -1.0E10 ) -* .. Scalar Arguments .. - REAL TRANSL - INTEGER KL, KU, LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - REAL A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - REAL SBEG - EXTERNAL SBEG -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Executable Statements .. - GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'S' - TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - IF( ( I.LE.J.AND.J - I.LE.KU ).OR. - $ ( I.GE.J.AND.I - J.LE.KL ) )THEN - A( I, J ) = SBEG( RESET ) + TRANSL - ELSE - A( I, J ) = ZERO - END IF - IF( I.NE.J )THEN - IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'GB' )THEN - DO 90 J = 1, N - DO 60 I1 = 1, KU + 1 - J - AA( I1 + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) - AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) - 70 CONTINUE - DO 80 I3 = I2, LDA - AA( I3 + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 130 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 100 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 100 CONTINUE - DO 110 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 110 CONTINUE - DO 120 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 120 CONTINUE - 130 CONTINUE - ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN - DO 170 J = 1, N - IF( UPPER )THEN - KK = KL + 1 - IBEG = MAX( 1, KL + 2 - J ) - IF( UNIT )THEN - IEND = KL - ELSE - IEND = KL + 1 - END IF - ELSE - KK = 1 - IF( UNIT )THEN - IBEG = 2 - ELSE - IBEG = 1 - END IF - IEND = MIN( KL + 1, 1 + M - J ) - END IF - DO 140 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 140 CONTINUE - DO 150 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) - 150 CONTINUE - DO 160 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 160 CONTINUE - 170 CONTINUE - ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN - IOFF = 0 - DO 190 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 180 I = IBEG, IEND - IOFF = IOFF + 1 - AA( IOFF ) = A( I, J ) - IF( I.EQ.J )THEN - IF( UNIT ) - $ AA( IOFF ) = ROGUE - END IF - 180 CONTINUE - 190 CONTINUE - END IF - RETURN -* -* End of SMAKE. -* - END - SUBROUTINE SMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL ALPHA, BETA, EPS, ERR - INTEGER INCX, INCY, M, N, NMAX, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANS -* .. Array Arguments .. - REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), - $ YY( * ) -* .. Local Scalars .. - REAL ERRI - INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL - LOGICAL TRAN -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. Executable Statements .. - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF - IF( INCX.LT.0 )THEN - KX = NL - INCXL = -1 - ELSE - KX = 1 - INCXL = 1 - END IF - IF( INCY.LT.0 )THEN - KY = ML - INCYL = -1 - ELSE - KY = 1 - INCYL = 1 - END IF -* -* Compute expected result in YT using data in A, X and Y. -* Compute gauges in G. -* - IY = KY - DO 30 I = 1, ML - YT( IY ) = ZERO - G( IY ) = ZERO - JX = KX - IF( TRAN )THEN - DO 10 J = 1, NL - YT( IY ) = YT( IY ) + A( J, I )*X( JX ) - G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) ) - JX = JX + INCXL - 10 CONTINUE - ELSE - DO 20 J = 1, NL - YT( IY ) = YT( IY ) + A( I, J )*X( JX ) - G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) ) - JX = JX + INCXL - 20 CONTINUE - END IF - YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) - G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) ) - IY = IY + INCYL - 30 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 40 I = 1, ML - ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS - IF( G( I ).NE.ZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.ONE ) - $ GO TO 50 - 40 CONTINUE -* If the loop completes, all results are at least half accurate. - GO TO 70 -* -* Report fatal error. -* - 50 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 60 I = 1, ML - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, YT( I ), - $ YY( 1 + ( I - 1 )*ABS( INCY ) ) - ELSE - WRITE( NOUT, FMT = 9998 )I, - $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I) - END IF - 60 CONTINUE -* - 70 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', - $ 'TED RESULT' ) - 9998 FORMAT( 1X, I7, 2G18.6 ) -* -* End of SMVCH. -* - END - LOGICAL FUNCTION LSE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - REAL RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LSE = .TRUE. - GO TO 30 - 20 CONTINUE - LSE = .FALSE. - 30 RETURN -* -* End of LSE. -* - END - LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE', 'SY' or 'SP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - REAL AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LSERES = .TRUE. - GO TO 80 - 70 CONTINUE - LSERES = .FALSE. - 80 RETURN -* -* End of LSERES. -* - END - REAL FUNCTION SBEG( RESET ) -* -* Generates random numbers uniformly distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, MI -* .. Save statement .. - SAVE I, IC, MI -* .. Intrinsic Functions .. - INTRINSIC REAL -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - I = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I is bounded between 1 and 999. -* If initial I = 1,2,3,6,7 or 9, the period will be 50. -* If initial I = 4 or 8, the period will be 25. -* If initial I = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I in 6. -* - IC = IC + 1 - 10 I = I*MI - I = I - 1000*( I/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - SBEG = REAL( I - 500 )/1001.0 - RETURN -* -* End of SBEG. -* - END - REAL FUNCTION SDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* -* .. Scalar Arguments .. - REAL X, Y -* .. Executable Statements .. - SDIFF = X - Y - RETURN -* -* End of SDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 2 BLAS -* routines. -* -* XERBLA is an error handler for the Level 2 BLAS routines. -* -* It is called by the Level 2 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/sblat3.dat b/eigen/blas/testing/sblat3.dat deleted file mode 100644 index 680e736..0000000 --- a/eigen/blas/testing/sblat3.dat +++ /dev/null @@ -1,20 +0,0 @@ -'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. diff --git a/eigen/blas/testing/sblat3.f b/eigen/blas/testing/sblat3.f deleted file mode 100644 index 8792696..0000000 --- a/eigen/blas/testing/sblat3.f +++ /dev/null @@ -1,2873 +0,0 @@ -*> \brief \b SBLAT3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM SBLAT3 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the REAL Level 3 Blas. -*> -*> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 6 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 20 lines: -*> 'sblat3.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 3 NUMBER OF VALUES OF ALPHA -*> 0.0 1.0 0.7 VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> 0.0 1.0 1.3 VALUES OF BETA -*> SGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> STRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> STRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. -*> A Set of Level 3 Basic Linear Algebra Subprograms. -*> -*> Technical Memorandum No.88 (Revision 1), Mathematics and -*> Computer Science Division, Argonne National Laboratory, 9700 -*> South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup single_blas_testing -* -* ===================================================================== - PROGRAM SBLAT3 -* -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 6 ) - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) - INTEGER NMAX - PARAMETER ( NMAX = 65 ) - INTEGER NIDMAX, NALMAX, NBEMAX - PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), - $ BB( NMAX*NMAX ), BET( NBEMAX ), - $ BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ G( NMAX ), W( 2*NMAX ) - INTEGER IDIM( NIDMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - REAL SDIFF - LOGICAL LSE - EXTERNAL SDIFF, LSE -* .. External Subroutines .. - EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHKE, SMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', - $ 'SSYRK ', 'SSYR2K'/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 220 - END IF - 10 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9984 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 20 I = 1, NSUBS - LTEST( I ) = .FALSE. - 20 CONTINUE - 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT - DO 40 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 50 - 40 CONTINUE - WRITE( NOUT, FMT = 9990 )SNAMET - STOP - 50 LTEST( I ) = LTESTT - GO TO 30 -* - 60 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(ZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of SMMCH using exact data. -* - N = MIN( 32, NMAX ) - DO 100 J = 1, N - DO 90 I = 1, N - AB( I, J ) = MAX( I - J + 1, 0 ) - 90 CONTINUE - AB( J, NMAX + 1 ) = J - AB( 1, NMAX + J ) = J - C( J, 1 ) = ZERO - 100 CONTINUE - DO 110 J = 1, N - CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 110 CONTINUE -* CC holds the exact result. On exit from SMMCH CT holds -* the result computed by SMMCH. - TRANSA = 'N' - TRANSB = 'N' - CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'T' - CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - DO 120 J = 1, N - AB( J, NMAX + 1 ) = N - J + 1 - AB( 1, NMAX + J ) = N - J + 1 - 120 CONTINUE - DO 130 J = 1, N - CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - - $ ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE - TRANSA = 'T' - TRANSB = 'N' - CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'T' - CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LSE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 200 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM -* Test SGEMM, 01. - 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test SSYMM, 02. - 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test STRMM, 03, STRSM, 04. - 160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, - $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) - GO TO 190 -* Test SSYRK, 05. - 170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test SSYR2K, 06. - 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) - GO TO 190 -* - 190 IF( FATAL.AND.SFATAL ) - $ GO TO 210 - END IF - 200 CONTINUE - WRITE( NOUT, FMT = 9986 ) - GO TO 230 -* - 210 CONTINUE - WRITE( NOUT, FMT = 9985 ) - GO TO 230 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9991 ) -* - 230 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' TESTS OF THE REAL LEVEL 3 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9994 FORMAT( ' FOR N ', 9I6 ) - 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) - 9992 FORMAT( ' FOR BETA ', 7F6.1 ) - 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1, - $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', - $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', - $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', - $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9986 FORMAT( /' END OF TESTS' ) - 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of SBLAT3. -* - END - SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests SGEMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX - INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, - $ MA, MB, MS, N, NA, NARGS, NB, NC, NS - LOGICAL NULL, RESET, SAME, TRANA, TRANB - CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SGEMM, SMAKE, SMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. -* - NARGS = 13 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 110 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICA = 1, 3 - TRANSA = ICH( ICA: ICA ) - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' -* - IF( TRANA )THEN - MA = K - NA = M - ELSE - MA = M - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICB = 1, 3 - TRANSB = ICH( ICB: ICB ) - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* - IF( TRANB )THEN - MB = N - NB = K - ELSE - MB = K - NB = N - END IF -* Set LDB to 1 more than minimum value if room. - LDB = MB - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 70 - LBB = LDB*NB -* -* Generate the matrix B. -* - CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, - $ LDB, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, - $ CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANAS = TRANSA - TRANBS = TRANSB - MS = M - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, - $ BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL SGEMM( TRANSA, TRANSB, M, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANSA.EQ.TRANAS - ISAME( 2 ) = TRANSB.EQ.TRANBS - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LSE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LSE( BS, BB, LBB ) - ISAME( 10 ) = LDBS.EQ.LDB - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LSE( CS, CC, LCC ) - ELSE - ISAME( 12 ) = LSERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 13 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL SMMCH( TRANSA, TRANSB, M, N, K, - $ ALPHA, A, NMAX, B, NMAX, BETA, - $ C, NMAX, CT, G, CC, LDC, EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, - $ ALPHA, LDA, LDB, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', - $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', - $ 'C,', I3, ').' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK1. -* - END - SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests SSYMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX - INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, - $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, - $ NARGS, NC, NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 SIDE, SIDES, UPLO, UPLOS - CHARACTER*2 ICHS, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, SSYMM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHS/'LR'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 90 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 90 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 90 - LBB = LDB*N -* -* Generate the matrix B. -* - CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, - $ ZERO ) -* - DO 80 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' -* - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* -* Generate the symmetric matrix A. -* - CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, - $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 110 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LSE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LSE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LSE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LSERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 110 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL SMMCH( 'N', 'N', M, N, M, ALPHA, A, - $ NMAX, B, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL SMMCH( 'N', 'N', M, N, N, ALPHA, B, - $ NMAX, A, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 120 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC -* - 120 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK2. -* - END - SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, - $ B, BB, BS, CT, G, C ) -* -* Tests STRMM and STRSM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, ERR, ERRMAX - INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, - $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, - $ NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, - $ UPLOS - CHARACTER*2 ICHD, ICHS, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, STRMM, STRSM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ -* .. Executable Statements .. -* - NARGS = 11 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* Set up zero matrix for SMMCH. - DO 20 J = 1, NMAX - DO 10 I = 1, NMAX - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* - DO 140 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 130 - LBB = LDB*N - NULL = M.LE.0.OR.N.LE.0 -* - DO 120 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 130 - LAA = LDA*NA -* - DO 110 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 100 ICT = 1, 3 - TRANSA = ICHT( ICT: ICT ) -* - DO 90 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - CALL SMAKE( 'TR', UPLO, DIAG, NA, NA, A, - $ NMAX, AA, LDA, RESET, ZERO ) -* -* Generate the matrix B. -* - CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, - $ BB, LDB, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - TRANAS = TRANSA - DIAGS = DIAG - MS = M - NS = N - ALS = ALPHA - DO 30 I = 1, LAA - AS( I ) = AA( I ) - 30 CONTINUE - LDAS = LDA - DO 40 I = 1, LBB - BS( I ) = BB( I ) - 40 CONTINUE - LDBS = LDB -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL STRMM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL STRSM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = TRANAS.EQ.TRANSA - ISAME( 4 ) = DIAGS.EQ.DIAG - ISAME( 5 ) = MS.EQ.M - ISAME( 6 ) = NS.EQ.N - ISAME( 7 ) = ALS.EQ.ALPHA - ISAME( 8 ) = LSE( AS, AA, LAA ) - ISAME( 9 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 10 ) = LSE( BS, BB, LBB ) - ELSE - ISAME( 10 ) = LSERES( 'GE', ' ', M, N, BS, - $ BB, LDB ) - END IF - ISAME( 11 ) = LDBS.EQ.LDB -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 50 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 50 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MM' )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL SMMCH( TRANSA, 'N', M, N, M, - $ ALPHA, A, NMAX, B, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL SMMCH( 'N', TRANSA, M, N, N, - $ ALPHA, B, NMAX, A, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN -* -* Compute approximation to original -* matrix. -* - DO 70 J = 1, N - DO 60 I = 1, M - C( I, J ) = BB( I + ( J - 1 )* - $ LDB ) - BB( I + ( J - 1 )*LDB ) = ALPHA* - $ B( I, J ) - 60 CONTINUE - 70 CONTINUE -* - IF( LEFT )THEN - CALL SMMCH( TRANSA, 'N', M, N, M, - $ ONE, A, NMAX, C, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - ELSE - CALL SMMCH( 'N', TRANSA, M, N, N, - $ ONE, C, NMAX, A, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - END IF - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 150 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, LDA, LDB -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ') .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK3. -* - END - SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests SSYRK. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, - $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, - $ NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, SSYRK -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NTC'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 10 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - BETS = BETA - DO 20 I = 1, LCC - CS( I ) = CC( I ) - 20 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL SSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LSE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = BETS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LSE( CS, CC, LCC ) - ELSE - ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 10 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - JC = 1 - DO 40 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA, - $ A( 1, JJ ), NMAX, - $ A( 1, J ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA, - $ A( JJ, 1 ), NMAX, - $ A( J, 1 ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - 40 CONTINUE - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK4. -* - END - SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) -* -* Tests SSYR2K. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0 ) -* .. Scalar Arguments .. - REAL EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), - $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), - $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ G( NMAX ), W( 2*NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, - $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, - $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LSE, LSERES - EXTERNAL LSE, LSERES -* .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, SSYR2K -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NTC'/, ICHU/'UL'/ -* .. Executable Statements .. -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = ZERO -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 130 - LCC = LDC*N - NULL = N.LE.0 -* - DO 120 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 110 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*NA -* -* Generate the matrix A. -* - IF( TRAN )THEN - CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, - $ LDA, RESET, ZERO ) - ELSE - CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, - $ RESET, ZERO ) - END IF -* -* Generate the matrix B. -* - LDB = LDA - LBB = LAA - IF( TRAN )THEN - CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), - $ 2*NMAX, BB, LDB, RESET, ZERO ) - ELSE - CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), - $ NMAX, BB, LDB, RESET, ZERO ) - END IF -* - DO 100 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 90 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 80 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BETS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LSE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LSE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BETS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LSE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - JJAB = 1 - JC = 1 - DO 70 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - DO 50 I = 1, K - W( I ) = AB( ( J - 1 )*2*NMAX + K + - $ I ) - W( K + I ) = AB( ( J - 1 )*2*NMAX + - $ I ) - 50 CONTINUE - CALL SMMCH( 'T', 'N', LJ, 1, 2*K, - $ ALPHA, AB( JJAB ), 2*NMAX, - $ W, 2*NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - DO 60 I = 1, K - W( I ) = AB( ( K + I - 1 )*NMAX + - $ J ) - W( K + I ) = AB( ( I - 1 )*NMAX + - $ J ) - 60 CONTINUE - CALL SMMCH( 'N', 'N', LJ, 1, 2*K, - $ ALPHA, AB( JJ ), NMAX, W, - $ 2*NMAX, BETA, C( JJ, J ), - $ NMAX, CT, G, CC( JC ), LDC, - $ EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - IF( TRAN ) - $ JJAB = JJAB + 2*NMAX - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 140 - 70 CONTINUE - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, BETA, LDC -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of SCHK5. -* - END - SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 3 Blas. -* Requires a special version of the error-handling routine XERBLA. -* A, B and C should not need to be defined. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* 3-19-92: Initialize ALPHA and BETA (eca) -* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca) -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Parameters .. - REAL ONE, TWO - PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 ) -* .. Local Scalars .. - REAL ALPHA, BETA -* .. Local Arrays .. - REAL A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM, - $ STRSM -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. -* -* Initialize ALPHA and BETA. -* - ALPHA = ONE - BETA = TWO -* - GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM - 10 INFOT = 1 - CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL SGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 20 INFOT = 1 - CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 30 INFOT = 1 - CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 40 INFOT = 1 - CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL STRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL STRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL STRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL STRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 50 INFOT = 1 - CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 - 60 INFOT = 1 - CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL SSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 70 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of SCHKE. -* - END - SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, - $ TRANSL ) -* -* Generates values for an M by N matrix A. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'SY' or 'TR'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) - REAL ROGUE - PARAMETER ( ROGUE = -1.0E10 ) -* .. Scalar Arguments .. - REAL TRANSL - INTEGER LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - REAL A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - REAL SBEG - EXTERNAL SBEG -* .. Executable Statements .. - GEN = TYPE.EQ.'GE' - SYM = TYPE.EQ.'SY' - TRI = TYPE.EQ.'TR' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - A( I, J ) = SBEG( RESET ) + TRANSL - IF( I.NE.J )THEN -* Set some elements to zero - IF( N.GT.3.AND.J.EQ.N/2 ) - $ A( I, J ) = ZERO - IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 90 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 60 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 70 CONTINUE - DO 80 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - END IF - RETURN -* -* End of SMAKE. -* - END - SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, - $ NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0, ONE = 1.0 ) -* .. Scalar Arguments .. - REAL ALPHA, BETA, EPS, ERR - INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANSA, TRANSB -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ CC( LDCC, * ), CT( * ), G( * ) -* .. Local Scalars .. - REAL ERRI - INTEGER I, J, K - LOGICAL TRANA, TRANB -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. Executable Statements .. - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* -* Compute expected result, one column at a time, in CT using data -* in A, B and C. -* Compute gauges in G. -* - DO 120 J = 1, N -* - DO 10 I = 1, M - CT( I ) = ZERO - G( I ) = ZERO - 10 CONTINUE - IF( .NOT.TRANA.AND..NOT.TRANB )THEN - DO 30 K = 1, KK - DO 20 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( K, J ) - G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( TRANA.AND..NOT.TRANB )THEN - DO 50 K = 1, KK - DO 40 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( K, J ) - G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) - 40 CONTINUE - 50 CONTINUE - ELSE IF( .NOT.TRANA.AND.TRANB )THEN - DO 70 K = 1, KK - DO 60 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( J, K ) - G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) - 60 CONTINUE - 70 CONTINUE - ELSE IF( TRANA.AND.TRANB )THEN - DO 90 K = 1, KK - DO 80 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( J, K ) - G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) - 80 CONTINUE - 90 CONTINUE - END IF - DO 100 I = 1, M - CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) - G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) - 100 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 110 I = 1, M - ERRI = ABS( CT( I ) - CC( I, J ) )/EPS - IF( G( I ).NE.ZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.ONE ) - $ GO TO 130 - 110 CONTINUE -* - 120 CONTINUE -* -* If the loop completes, all results are at least half accurate. - GO TO 150 -* -* Report fatal error. -* - 130 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 140 I = 1, M - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) - ELSE - WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) - END IF - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9997 )J -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', - $ 'TED RESULT' ) - 9998 FORMAT( 1X, I7, 2G18.6 ) - 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) -* -* End of SMMCH. -* - END - LOGICAL FUNCTION LSE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - REAL RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LSE = .TRUE. - GO TO 30 - 20 CONTINUE - LSE = .FALSE. - 30 RETURN -* -* End of LSE. -* - END - LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE' or 'SY'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - REAL AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LSERES = .TRUE. - GO TO 80 - 70 CONTINUE - LSERES = .FALSE. - 80 RETURN -* -* End of LSERES. -* - END - REAL FUNCTION SBEG( RESET ) -* -* Generates random numbers uniformly distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, MI -* .. Save statement .. - SAVE I, IC, MI -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - I = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I is bounded between 1 and 999. -* If initial I = 1,2,3,6,7 or 9, the period will be 50. -* If initial I = 4 or 8, the period will be 25. -* If initial I = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I in 6. -* - IC = IC + 1 - 10 I = I*MI - I = I - 1000*( I/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - SBEG = ( I - 500 )/1001.0 - RETURN -* -* End of SBEG. -* - END - REAL FUNCTION SDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - REAL X, Y -* .. Executable Statements .. - SDIFF = X - Y - RETURN -* -* End of SDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 3 BLAS -* routines. -* -* XERBLA is an error handler for the Level 3 BLAS routines. -* -* It is called by the Level 3 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/zblat1.f b/eigen/blas/testing/zblat1.f deleted file mode 100644 index d30112c..0000000 --- a/eigen/blas/testing/zblat1.f +++ /dev/null @@ -1,724 +0,0 @@ -*> \brief \b ZBLAT1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM ZBLAT1 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX*16 Level 1 BLAS. -*> -*> Based upon the original BLAS test routine together with: -*> F06GAF Example Program Text -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex16_blas_testing -* -* ===================================================================== - PROGRAM ZBLAT1 -* -* -- Reference BLAS test routine (version 3.4.1) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - DOUBLE PRECISION SFAC - INTEGER IC -* .. External Subroutines .. - EXTERNAL CHECK1, CHECK2, HEADER -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA SFAC/9.765625D-4/ -* .. Executable Statements .. - WRITE (NOUT,99999) - DO 20 IC = 1, 10 - ICASE = IC - CALL HEADER -* -* Initialize PASS, INCX, INCY, and MODE for a new case. -* The value 9999 for INCX, INCY or MODE will appear in the -* detailed output, if any, for cases that do not involve -* these parameters. -* - PASS = .TRUE. - INCX = 9999 - INCY = 9999 - MODE = 9999 - IF (ICASE.LE.5) THEN - CALL CHECK2(SFAC) - ELSE IF (ICASE.GE.6) THEN - CALL CHECK1(SFAC) - END IF -* -- Print - IF (PASS) WRITE (NOUT,99998) - 20 CONTINUE - STOP -* -99999 FORMAT (' Complex BLAS Test Program Results',/1X) -99998 FORMAT (' ----- PASS -----') - END - SUBROUTINE HEADER -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Arrays .. - CHARACTER*6 L(10) -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA L(1)/'ZDOTC '/ - DATA L(2)/'ZDOTU '/ - DATA L(3)/'ZAXPY '/ - DATA L(4)/'ZCOPY '/ - DATA L(5)/'ZSWAP '/ - DATA L(6)/'DZNRM2'/ - DATA L(7)/'DZASUM'/ - DATA L(8)/'ZSCAL '/ - DATA L(9)/'ZDSCAL'/ - DATA L(10)/'IZAMAX'/ -* .. Executable Statements .. - WRITE (NOUT,99999) ICASE, L(ICASE) - RETURN -* -99999 FORMAT (/' Test of subprogram number',I3,12X,A6) - END - SUBROUTINE CHECK1(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - DOUBLE PRECISION SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - COMPLEX*16 CA - DOUBLE PRECISION SA - INTEGER I, J, LEN, NP1 -* .. Local Arrays .. - COMPLEX*16 CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), - + MWPCS(5), MWPCT(5) - DOUBLE PRECISION STRUE2(5), STRUE4(5) - INTEGER ITRUE3(5) -* .. External Functions .. - DOUBLE PRECISION DZASUM, DZNRM2 - INTEGER IZAMAX - EXTERNAL DZASUM, DZNRM2, IZAMAX -* .. External Subroutines .. - EXTERNAL ZSCAL, ZDSCAL, CTEST, ITEST1, STEST1 -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA SA, CA/0.3D0, (0.4D0,-0.7D0)/ - DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0), - + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), - + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), - + (1.0D0,2.0D0), (0.3D0,-0.4D0), (3.0D0,4.0D0), - + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), - + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), - + (0.1D0,-0.3D0), (0.5D0,-0.1D0), (5.0D0,6.0D0), - + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), - + (5.0D0,6.0D0), (5.0D0,6.0D0), (0.1D0,0.1D0), - + (-0.6D0,0.1D0), (0.1D0,-0.3D0), (7.0D0,8.0D0), - + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0), - + (7.0D0,8.0D0), (0.3D0,0.1D0), (0.5D0,0.0D0), - + (0.0D0,0.5D0), (0.0D0,0.2D0), (2.0D0,3.0D0), - + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0)/ - DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0), - + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), - + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), - + (4.0D0,5.0D0), (0.3D0,-0.4D0), (6.0D0,7.0D0), - + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), - + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), - + (0.1D0,-0.3D0), (8.0D0,9.0D0), (0.5D0,-0.1D0), - + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0), - + (2.0D0,5.0D0), (2.0D0,5.0D0), (0.1D0,0.1D0), - + (3.0D0,6.0D0), (-0.6D0,0.1D0), (4.0D0,7.0D0), - + (0.1D0,-0.3D0), (7.0D0,2.0D0), (7.0D0,2.0D0), - + (7.0D0,2.0D0), (0.3D0,0.1D0), (5.0D0,8.0D0), - + (0.5D0,0.0D0), (6.0D0,9.0D0), (0.0D0,0.5D0), - + (8.0D0,3.0D0), (0.0D0,0.2D0), (9.0D0,4.0D0)/ - DATA STRUE2/0.0D0, 0.5D0, 0.6D0, 0.7D0, 0.8D0/ - DATA STRUE4/0.0D0, 0.7D0, 1.0D0, 1.3D0, 1.6D0/ - DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0), - + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), - + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), - + (1.0D0,2.0D0), (-0.16D0,-0.37D0), (3.0D0,4.0D0), - + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), - + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), - + (-0.17D0,-0.19D0), (0.13D0,-0.39D0), - + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), - + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), - + (0.11D0,-0.03D0), (-0.17D0,0.46D0), - + (-0.17D0,-0.19D0), (7.0D0,8.0D0), (7.0D0,8.0D0), - + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0), - + (0.19D0,-0.17D0), (0.20D0,-0.35D0), - + (0.35D0,0.20D0), (0.14D0,0.08D0), - + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0), - + (2.0D0,3.0D0)/ - DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0), - + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), - + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), - + (4.0D0,5.0D0), (-0.16D0,-0.37D0), (6.0D0,7.0D0), - + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), - + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), - + (-0.17D0,-0.19D0), (8.0D0,9.0D0), - + (0.13D0,-0.39D0), (2.0D0,5.0D0), (2.0D0,5.0D0), - + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0), - + (0.11D0,-0.03D0), (3.0D0,6.0D0), - + (-0.17D0,0.46D0), (4.0D0,7.0D0), - + (-0.17D0,-0.19D0), (7.0D0,2.0D0), (7.0D0,2.0D0), - + (7.0D0,2.0D0), (0.19D0,-0.17D0), (5.0D0,8.0D0), - + (0.20D0,-0.35D0), (6.0D0,9.0D0), - + (0.35D0,0.20D0), (8.0D0,3.0D0), - + (0.14D0,0.08D0), (9.0D0,4.0D0)/ - DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0), - + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), - + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), - + (1.0D0,2.0D0), (0.09D0,-0.12D0), (3.0D0,4.0D0), - + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), - + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), - + (0.03D0,-0.09D0), (0.15D0,-0.03D0), - + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), - + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), - + (0.03D0,0.03D0), (-0.18D0,0.03D0), - + (0.03D0,-0.09D0), (7.0D0,8.0D0), (7.0D0,8.0D0), - + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0), - + (0.09D0,0.03D0), (0.15D0,0.00D0), - + (0.00D0,0.15D0), (0.00D0,0.06D0), (2.0D0,3.0D0), - + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0)/ - DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0), - + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), - + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), - + (4.0D0,5.0D0), (0.09D0,-0.12D0), (6.0D0,7.0D0), - + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), - + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), - + (0.03D0,-0.09D0), (8.0D0,9.0D0), - + (0.15D0,-0.03D0), (2.0D0,5.0D0), (2.0D0,5.0D0), - + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0), - + (0.03D0,0.03D0), (3.0D0,6.0D0), - + (-0.18D0,0.03D0), (4.0D0,7.0D0), - + (0.03D0,-0.09D0), (7.0D0,2.0D0), (7.0D0,2.0D0), - + (7.0D0,2.0D0), (0.09D0,0.03D0), (5.0D0,8.0D0), - + (0.15D0,0.00D0), (6.0D0,9.0D0), (0.00D0,0.15D0), - + (8.0D0,3.0D0), (0.00D0,0.06D0), (9.0D0,4.0D0)/ - DATA ITRUE3/0, 1, 2, 2, 2/ -* .. Executable Statements .. - DO 60 INCX = 1, 2 - DO 40 NP1 = 1, 5 - N = NP1 - 1 - LEN = 2*MAX(N,1) -* .. Set vector arguments .. - DO 20 I = 1, LEN - CX(I) = CV(I,NP1,INCX) - 20 CONTINUE - IF (ICASE.EQ.6) THEN -* .. DZNRM2 .. - CALL STEST1(DZNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1), - + SFAC) - ELSE IF (ICASE.EQ.7) THEN -* .. DZASUM .. - CALL STEST1(DZASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1), - + SFAC) - ELSE IF (ICASE.EQ.8) THEN -* .. ZSCAL .. - CALL ZSCAL(N,CA,CX,INCX) - CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), - + SFAC) - ELSE IF (ICASE.EQ.9) THEN -* .. ZDSCAL .. - CALL ZDSCAL(N,SA,CX,INCX) - CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), - + SFAC) - ELSE IF (ICASE.EQ.10) THEN -* .. IZAMAX .. - CALL ITEST1(IZAMAX(N,CX,INCX),ITRUE3(NP1)) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' - STOP - END IF -* - 40 CONTINUE - 60 CONTINUE -* - INCX = 1 - IF (ICASE.EQ.8) THEN -* ZSCAL -* Add a test for alpha equal to zero. - CA = (0.0D0,0.0D0) - DO 80 I = 1, 5 - MWPCT(I) = (0.0D0,0.0D0) - MWPCS(I) = (1.0D0,1.0D0) - 80 CONTINUE - CALL ZSCAL(5,CA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) - ELSE IF (ICASE.EQ.9) THEN -* ZDSCAL -* Add a test for alpha equal to zero. - SA = 0.0D0 - DO 100 I = 1, 5 - MWPCT(I) = (0.0D0,0.0D0) - MWPCS(I) = (1.0D0,1.0D0) - 100 CONTINUE - CALL ZDSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) -* Add a test for alpha equal to one. - SA = 1.0D0 - DO 120 I = 1, 5 - MWPCT(I) = CX(I) - MWPCS(I) = CX(I) - 120 CONTINUE - CALL ZDSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) -* Add a test for alpha equal to minus one. - SA = -1.0D0 - DO 140 I = 1, 5 - MWPCT(I) = -CX(I) - MWPCS(I) = -CX(I) - 140 CONTINUE - CALL ZDSCAL(5,SA,CX,INCX) - CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) - END IF - RETURN - END - SUBROUTINE CHECK2(SFAC) -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - DOUBLE PRECISION SFAC -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - COMPLEX*16 CA - INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY -* .. Local Arrays .. - COMPLEX*16 CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14), - + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4), - + CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7) - INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) -* .. External Functions .. - COMPLEX*16 ZDOTC, ZDOTU - EXTERNAL ZDOTC, ZDOTU -* .. External Subroutines .. - EXTERNAL ZAXPY, ZCOPY, ZSWAP, CTEST -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Data statements .. - DATA CA/(0.4D0,-0.7D0)/ - DATA INCXS/1, 2, -2, -1/ - DATA INCYS/1, -2, 1, -2/ - DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ - DATA NS/0, 1, 2, 4/ - DATA CX1/(0.7D0,-0.8D0), (-0.4D0,-0.7D0), - + (-0.1D0,-0.9D0), (0.2D0,-0.8D0), - + (-0.9D0,-0.4D0), (0.1D0,0.4D0), (-0.6D0,0.6D0)/ - DATA CY1/(0.6D0,-0.6D0), (-0.9D0,0.5D0), - + (0.7D0,-0.6D0), (0.1D0,-0.5D0), (-0.1D0,-0.2D0), - + (-0.5D0,-0.3D0), (0.8D0,-0.7D0)/ - DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.32D0,-1.41D0), - + (-1.55D0,0.5D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.32D0,-1.41D0), (-1.55D0,0.5D0), - + (0.03D0,-0.89D0), (-0.38D0,-0.96D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/ - DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (-0.07D0,-0.89D0), - + (-0.9D0,0.5D0), (0.42D0,-1.41D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.78D0,0.06D0), (-0.9D0,0.5D0), - + (0.06D0,-0.13D0), (0.1D0,-0.5D0), - + (-0.77D0,-0.49D0), (-0.5D0,-0.3D0), - + (0.52D0,-1.51D0)/ - DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (-0.07D0,-0.89D0), - + (-1.18D0,-0.31D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.78D0,0.06D0), (-1.54D0,0.97D0), - + (0.03D0,-0.89D0), (-0.18D0,-1.31D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/ - DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.32D0,-1.41D0), (-0.9D0,0.5D0), - + (0.05D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.32D0,-1.41D0), - + (-0.9D0,0.5D0), (0.05D0,-0.6D0), (0.1D0,-0.5D0), - + (-0.77D0,-0.49D0), (-0.5D0,-0.3D0), - + (0.32D0,-1.16D0)/ - DATA CT7/(0.0D0,0.0D0), (-0.06D0,-0.90D0), - + (0.65D0,-0.47D0), (-0.34D0,-1.22D0), - + (0.0D0,0.0D0), (-0.06D0,-0.90D0), - + (-0.59D0,-1.46D0), (-1.04D0,-0.04D0), - + (0.0D0,0.0D0), (-0.06D0,-0.90D0), - + (-0.83D0,0.59D0), (0.07D0,-0.37D0), - + (0.0D0,0.0D0), (-0.06D0,-0.90D0), - + (-0.76D0,-1.15D0), (-1.33D0,-1.82D0)/ - DATA CT6/(0.0D0,0.0D0), (0.90D0,0.06D0), - + (0.91D0,-0.77D0), (1.80D0,-0.10D0), - + (0.0D0,0.0D0), (0.90D0,0.06D0), (1.45D0,0.74D0), - + (0.20D0,0.90D0), (0.0D0,0.0D0), (0.90D0,0.06D0), - + (-0.55D0,0.23D0), (0.83D0,-0.39D0), - + (0.0D0,0.0D0), (0.90D0,0.06D0), (1.04D0,0.79D0), - + (1.95D0,1.22D0)/ - DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7D0,-0.8D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.6D0,-0.6D0), (-0.9D0,0.5D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.6D0,-0.6D0), - + (-0.9D0,0.5D0), (0.7D0,-0.6D0), (0.1D0,-0.5D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/ - DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7D0,-0.8D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.7D0,-0.6D0), (-0.4D0,-0.7D0), - + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.8D0,-0.7D0), - + (-0.4D0,-0.7D0), (-0.1D0,-0.2D0), - + (0.2D0,-0.8D0), (0.7D0,-0.6D0), (0.1D0,0.4D0), - + (0.6D0,-0.6D0)/ - DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7D0,-0.8D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (-0.9D0,0.5D0), (-0.4D0,-0.7D0), - + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.1D0,-0.5D0), - + (-0.4D0,-0.7D0), (0.7D0,-0.6D0), (0.2D0,-0.8D0), - + (-0.9D0,0.5D0), (0.1D0,0.4D0), (0.6D0,-0.6D0)/ - DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7D0,-0.8D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.6D0,-0.6D0), (0.7D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.6D0,-0.6D0), - + (0.7D0,-0.6D0), (-0.1D0,-0.2D0), (0.8D0,-0.7D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/ - DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.7D0,-0.8D0), (-0.4D0,-0.7D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.7D0,-0.8D0), - + (-0.4D0,-0.7D0), (-0.1D0,-0.9D0), - + (0.2D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0)/ - DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (-0.1D0,-0.9D0), (-0.9D0,0.5D0), - + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (-0.6D0,0.6D0), - + (-0.9D0,0.5D0), (-0.9D0,-0.4D0), (0.1D0,-0.5D0), - + (-0.1D0,-0.9D0), (-0.5D0,-0.3D0), - + (0.7D0,-0.8D0)/ - DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (-0.1D0,-0.9D0), (0.7D0,-0.8D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (-0.6D0,0.6D0), - + (-0.9D0,-0.4D0), (-0.1D0,-0.9D0), - + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0)/ - DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6D0,-0.6D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.7D0,-0.8D0), (-0.9D0,0.5D0), - + (-0.4D0,-0.7D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.7D0,-0.8D0), - + (-0.9D0,0.5D0), (-0.4D0,-0.7D0), (0.1D0,-0.5D0), - + (-0.1D0,-0.9D0), (-0.5D0,-0.3D0), - + (0.2D0,-0.8D0)/ - DATA CSIZE1/(0.0D0,0.0D0), (0.9D0,0.9D0), - + (1.63D0,1.73D0), (2.90D0,2.78D0)/ - DATA CSIZE3/(0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (1.17D0,1.17D0), - + (1.17D0,1.17D0), (1.17D0,1.17D0), - + (1.17D0,1.17D0), (1.17D0,1.17D0), - + (1.17D0,1.17D0), (1.17D0,1.17D0)/ - DATA CSIZE2/(0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), - + (0.0D0,0.0D0), (0.0D0,0.0D0), (1.54D0,1.54D0), - + (1.54D0,1.54D0), (1.54D0,1.54D0), - + (1.54D0,1.54D0), (1.54D0,1.54D0), - + (1.54D0,1.54D0), (1.54D0,1.54D0)/ -* .. Executable Statements .. - DO 60 KI = 1, 4 - INCX = INCXS(KI) - INCY = INCYS(KI) - MX = ABS(INCX) - MY = ABS(INCY) -* - DO 40 KN = 1, 4 - N = NS(KN) - KSIZE = MIN(2,KN) - LENX = LENS(KN,MX) - LENY = LENS(KN,MY) -* .. initialize all argument arrays .. - DO 20 I = 1, 7 - CX(I) = CX1(I) - CY(I) = CY1(I) - 20 CONTINUE - IF (ICASE.EQ.1) THEN -* .. ZDOTC .. - CDOT(1) = ZDOTC(N,CX,INCX,CY,INCY) - CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) - ELSE IF (ICASE.EQ.2) THEN -* .. ZDOTU .. - CDOT(1) = ZDOTU(N,CX,INCX,CY,INCY) - CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) - ELSE IF (ICASE.EQ.3) THEN -* .. ZAXPY .. - CALL ZAXPY(N,CA,CX,INCX,CY,INCY) - CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) - ELSE IF (ICASE.EQ.4) THEN -* .. ZCOPY .. - CALL ZCOPY(N,CX,INCX,CY,INCY) - CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0) - ELSE IF (ICASE.EQ.5) THEN -* .. ZSWAP .. - CALL ZSWAP(N,CX,INCX,CY,INCY) - CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0D0) - CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0) - ELSE - WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' - STOP - END IF -* - 40 CONTINUE - 60 CONTINUE - RETURN - END - SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) -* ********************************* STEST ************************** -* -* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO -* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE -* NEGLIGIBLE. -* -* C. L. LAWSON, JPL, 1974 DEC 10 -* -* .. Parameters .. - INTEGER NOUT - DOUBLE PRECISION ZERO - PARAMETER (NOUT=6, ZERO=0.0D0) -* .. Scalar Arguments .. - DOUBLE PRECISION SFAC - INTEGER LEN -* .. Array Arguments .. - DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN) -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - DOUBLE PRECISION SD - INTEGER I -* .. External Functions .. - DOUBLE PRECISION SDIFF - EXTERNAL SDIFF -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Executable Statements .. -* - DO 40 I = 1, LEN - SD = SCOMP(I) - STRUE(I) - IF (ABS(SFAC*SD) .LE. ABS(SSIZE(I))*EPSILON(ZERO)) - + GO TO 40 -* -* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). -* - IF ( .NOT. PASS) GO TO 20 -* PRINT FAIL MESSAGE AND HEADER. - PASS = .FALSE. - WRITE (NOUT,99999) - WRITE (NOUT,99998) - 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), - + STRUE(I), SD, SSIZE(I) - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY MODE I ', - + ' COMP(I) TRUE(I) DIFFERENCE', - + ' SIZE(I)',/1X) -99997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4) - END - SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) -* ************************* STEST1 ***************************** -* -* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN -* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE -* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. -* -* C.L. LAWSON, JPL, 1978 DEC 6 -* -* .. Scalar Arguments .. - DOUBLE PRECISION SCOMP1, SFAC, STRUE1 -* .. Array Arguments .. - DOUBLE PRECISION SSIZE(*) -* .. Local Arrays .. - DOUBLE PRECISION SCOMP(1), STRUE(1) -* .. External Subroutines .. - EXTERNAL STEST -* .. Executable Statements .. -* - SCOMP(1) = SCOMP1 - STRUE(1) = STRUE1 - CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) -* - RETURN - END - DOUBLE PRECISION FUNCTION SDIFF(SA,SB) -* ********************************* SDIFF ************************** -* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 -* -* .. Scalar Arguments .. - DOUBLE PRECISION SA, SB -* .. Executable Statements .. - SDIFF = SA - SB - RETURN - END - SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC) -* **************************** CTEST ***************************** -* -* C.L. LAWSON, JPL, 1978 DEC 6 -* -* .. Scalar Arguments .. - DOUBLE PRECISION SFAC - INTEGER LEN -* .. Array Arguments .. - COMPLEX*16 CCOMP(LEN), CSIZE(LEN), CTRUE(LEN) -* .. Local Scalars .. - INTEGER I -* .. Local Arrays .. - DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20) -* .. External Subroutines .. - EXTERNAL STEST -* .. Intrinsic Functions .. - INTRINSIC DIMAG, DBLE -* .. Executable Statements .. - DO 20 I = 1, LEN - SCOMP(2*I-1) = DBLE(CCOMP(I)) - SCOMP(2*I) = DIMAG(CCOMP(I)) - STRUE(2*I-1) = DBLE(CTRUE(I)) - STRUE(2*I) = DIMAG(CTRUE(I)) - SSIZE(2*I-1) = DBLE(CSIZE(I)) - SSIZE(2*I) = DIMAG(CSIZE(I)) - 20 CONTINUE -* - CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC) - RETURN - END - SUBROUTINE ITEST1(ICOMP,ITRUE) -* ********************************* ITEST1 ************************* -* -* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR -* EQUALITY. -* C. L. LAWSON, JPL, 1974 DEC 10 -* -* .. Parameters .. - INTEGER NOUT - PARAMETER (NOUT=6) -* .. Scalar Arguments .. - INTEGER ICOMP, ITRUE -* .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N - LOGICAL PASS -* .. Local Scalars .. - INTEGER ID -* .. Common blocks .. - COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS -* .. Executable Statements .. - IF (ICOMP.EQ.ITRUE) GO TO 40 -* -* HERE ICOMP IS NOT EQUAL TO ITRUE. -* - IF ( .NOT. PASS) GO TO 20 -* PRINT FAIL MESSAGE AND HEADER. - PASS = .FALSE. - WRITE (NOUT,99999) - WRITE (NOUT,99998) - 20 ID = ICOMP - ITRUE - WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID - 40 CONTINUE - RETURN -* -99999 FORMAT (' FAIL') -99998 FORMAT (/' CASE N INCX INCY MODE ', - + ' COMP TRUE DIFFERENCE', - + /1X) -99997 FORMAT (1X,I4,I3,3I5,2I36,I12) - END diff --git a/eigen/blas/testing/zblat2.dat b/eigen/blas/testing/zblat2.dat deleted file mode 100644 index c922440..0000000 --- a/eigen/blas/testing/zblat2.dat +++ /dev/null @@ -1,35 +0,0 @@ -'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. diff --git a/eigen/blas/testing/zblat2.f b/eigen/blas/testing/zblat2.f deleted file mode 100644 index 53129a1..0000000 --- a/eigen/blas/testing/zblat2.f +++ /dev/null @@ -1,3287 +0,0 @@ -*> \brief \b ZBLAT2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM ZBLAT2 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX*16 Level 2 Blas. -*> -*> The program must be driven by a short data file. The first 18 records -*> of the file are read using list-directed input, the last 17 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 35 lines: -*> 'zblat2.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 4 NUMBER OF VALUES OF K -*> 0 1 2 4 VALUES OF K -*> 4 NUMBER OF VALUES OF INCX AND INCY -*> 1 2 -1 -2 VALUES OF INCX AND INCY -*> 3 NUMBER OF VALUES OF ALPHA -*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -*> ZGEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZGBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHEMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTRMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTBMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTPMV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTRSV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTBSV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTPSV T PUT F FOR NO TEST. SAME COLUMNS. -*> ZGERC T PUT F FOR NO TEST. SAME COLUMNS. -*> ZGERU T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHER T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHPR T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHER2 T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHPR2 T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. -*> An extended set of Fortran Basic Linear Algebra Subprograms. -*> -*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics -*> and Computer Science Division, Argonne National Laboratory, -*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> Or -*> -*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms -*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford -*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st -*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. -*> -*> -*> -- Written on 10-August-1987. -*> Richard Hanson, Sandia National Labs. -*> Jeremy Du Croz, NAG Central Office. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex16_blas_testing -* -* ===================================================================== - PROGRAM ZBLAT2 -* -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 17 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) - INTEGER NMAX, INCMAX - PARAMETER ( NMAX = 65, INCMAX = 2 ) - INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX - PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, - $ NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, - $ NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANS - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), - $ X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( 2*NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - DOUBLE PRECISION DDIFF - LOGICAL LZE - EXTERNAL DDIFF, LZE -* .. External Subroutines .. - EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6, - $ ZCHKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'ZGEMV ', 'ZGBMV ', 'ZHEMV ', 'ZHBMV ', - $ 'ZHPMV ', 'ZTRMV ', 'ZTBMV ', 'ZTPMV ', - $ 'ZTRSV ', 'ZTBSV ', 'ZTPSV ', 'ZGERC ', - $ 'ZGERU ', 'ZHER ', 'ZHPR ', 'ZHER2 ', - $ 'ZHPR2 '/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 230 - END IF - 10 CONTINUE -* Values of K - READ( NIN, FMT = * )NKB - IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN - WRITE( NOUT, FMT = 9997 )'K', NKBMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) - DO 20 I = 1, NKB - IF( KB( I ).LT.0 )THEN - WRITE( NOUT, FMT = 9995 ) - GO TO 230 - END IF - 20 CONTINUE -* Values of INCX and INCY - READ( NIN, FMT = * )NINC - IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN - WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) - DO 30 I = 1, NINC - IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN - WRITE( NOUT, FMT = 9994 )INCMAX - GO TO 230 - END IF - 30 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 230 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9993 ) - WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) - WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) - WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9980 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 40 I = 1, NSUBS - LTEST( I ) = .FALSE. - 40 CONTINUE - 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT - DO 60 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 70 - 60 CONTINUE - WRITE( NOUT, FMT = 9986 )SNAMET - STOP - 70 LTEST( I ) = LTESTT - GO TO 50 -* - 80 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(RZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of ZMVCH using exact data. -* - N = MIN( 32, NMAX ) - DO 120 J = 1, N - DO 110 I = 1, N - A( I, J ) = MAX( I - J + 1, 0 ) - 110 CONTINUE - X( J ) = J - Y( J ) = ZERO - 120 CONTINUE - DO 130 J = 1, N - YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE -* YY holds the exact result. On exit from ZMVCH YT holds -* the result computed by ZMVCH. - TRANS = 'N' - CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF - TRANS = 'T' - CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( YY, YT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 210 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 140, 150, 150, 150, 160, 160, - $ 160, 160, 160, 160, 170, 170, 180, - $ 180, 190, 190 )ISNUM -* Test ZGEMV, 01, and ZGBMV, 02. - 140 CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05. - 150 CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, - $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, - $ X, XX, XS, Y, YY, YS, YT, G ) - GO TO 200 -* Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08, -* ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11. - 160 CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) - GO TO 200 -* Test ZGERC, 12, ZGERU, 13. - 170 CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test ZHER, 14, and ZHPR, 15. - 180 CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) - GO TO 200 -* Test ZHER2, 16, and ZHPR2, 17. - 190 CALL ZCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, - $ YT, G, Z ) -* - 200 IF( FATAL.AND.SFATAL ) - $ GO TO 220 - END IF - 210 CONTINUE - WRITE( NOUT, FMT = 9982 ) - GO TO 240 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9981 ) - GO TO 240 -* - 230 CONTINUE - WRITE( NOUT, FMT = 9987 ) -* - 240 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) - 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', - $ I2 ) - 9993 FORMAT( ' TESTS OF THE COMPLEX*16 LEVEL 2 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9992 FORMAT( ' FOR N ', 9I6 ) - 9991 FORMAT( ' FOR K ', 7I6 ) - 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) - 9989 FORMAT( ' FOR ALPHA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9988 FORMAT( ' FOR BETA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9985 FORMAT( ' ERROR IN ZMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' ZMVCH WAS CALLED WITH TRANS = ', A1, - $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / - $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' - $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9982 FORMAT( /' END OF TESTS' ) - 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of ZBLAT2. -* - END - SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests ZGEMV and ZGBMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, - $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, - $ NL, NS - LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN - CHARACTER*1 TRANS, TRANSS - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZGBMV, ZGEMV, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 11 - ELSE IF( BANDED )THEN - NARGS = 13 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IKU = 1, NK - IF( BANDED )THEN - KU = KB( IKU ) - KL = MAX( KU - 1, 0 ) - ELSE - KU = N - 1 - KL = M - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = KL + KU + 1 - ELSE - LDA = M - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, - $ LDA, KL, KU, RESET, TRANSL ) -* - DO 90 IC = 1, 3 - TRANS = ICH( IC: IC ) - TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' -* - IF( TRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*NL -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, - $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) - IF( NL.GT.1 )THEN - X( NL/2 ) = ZERO - XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*ML -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL ZMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, - $ YY, ABS( INCY ), 0, ML - 1, - $ RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANSS = TRANS - MS = M - NS = N - KLS = KL - KUS = KU - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ TRANS, M, N, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL ZGEMV( TRANS, M, N, ALPHA, AA, - $ LDA, XX, INCX, BETA, YY, - $ INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANS, M, N, KL, KU, ALPHA, LDA, - $ INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL ZGBMV( TRANS, M, N, KL, KU, ALPHA, - $ AA, LDA, XX, INCX, BETA, - $ YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 130 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANS.EQ.TRANSS - ISAME( 2 ) = MS.EQ.M - ISAME( 3 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LZE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LZE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LZERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 4 ) = KLS.EQ.KL - ISAME( 5 ) = KUS.EQ.KU - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LZE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LZE( XS, XX, LX ) - ISAME( 10 ) = INCXS.EQ.INCX - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 12 ) = LZERES( 'GE', ' ', 1, - $ ML, YS, YY, - $ ABS( INCY ) ) - END IF - ISAME( 13 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 130 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL ZMVCH( TRANS, M, N, ALPHA, A, - $ NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 130 - ELSE -* Avoid repeating tests with M.le.0 or -* N.le.0. - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 140 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, - $ ALPHA, LDA, INCX, BETA, INCY - END IF -* - 140 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK1. -* - END - SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, - $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, - $ XS, Y, YY, YS, YT, G ) -* -* Tests ZHEMV, ZHBMV and ZHPMV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, - $ NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), - $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), - $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, - $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, - $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHBMV, ZHEMV, ZHPMV, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 10 - ELSE IF( BANDED )THEN - NARGS = 11 - ELSE IF( PACKED )THEN - NARGS = 9 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, - $ LDA, K, K, RESET, TRANSL ) -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - UPLOS = UPLO - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - BLS = BETA - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL ZHEMV( UPLO, N, ALPHA, AA, LDA, XX, - $ INCX, BETA, YY, INCY ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, N, K, ALPHA, LDA, INCX, BETA, - $ INCY - IF( REWI ) - $ REWIND NTRA - CALL ZHBMV( UPLO, N, K, ALPHA, AA, LDA, - $ XX, INCX, BETA, YY, INCY ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, N, ALPHA, INCX, BETA, INCY - IF( REWI ) - $ REWIND NTRA - CALL ZHPMV( UPLO, N, ALPHA, AA, XX, INCX, - $ BETA, YY, INCY ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LZE( AS, AA, LAA ) - ISAME( 5 ) = LDAS.EQ.LDA - ISAME( 6 ) = LZE( XS, XX, LX ) - ISAME( 7 ) = INCXS.EQ.INCX - ISAME( 8 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 9 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 9 ) = LZERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 10 ) = INCYS.EQ.INCY - ELSE IF( BANDED )THEN - ISAME( 3 ) = KS.EQ.K - ISAME( 4 ) = ALS.EQ.ALPHA - ISAME( 5 ) = LZE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - ISAME( 7 ) = LZE( XS, XX, LX ) - ISAME( 8 ) = INCXS.EQ.INCX - ISAME( 9 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 10 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 10 ) = LZERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 11 ) = INCYS.EQ.INCY - ELSE IF( PACKED )THEN - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LZE( AS, AA, LAA ) - ISAME( 5 ) = LZE( XS, XX, LX ) - ISAME( 6 ) = INCXS.EQ.INCX - ISAME( 7 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 8 ) = LZE( YS, YY, LY ) - ELSE - ISAME( 8 ) = LZERES( 'GE', ' ', 1, N, - $ YS, YY, ABS( INCY ) ) - END IF - ISAME( 9 ) = INCYS.EQ.INCY - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL ZMVCH( 'N', N, N, ALPHA, A, NMAX, X, - $ INCX, BETA, Y, INCY, YT, G, - $ YY, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0 - GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, - $ BETA, INCY - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, - $ INCX, BETA, INCY - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ BETA, INCY - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2, - $ ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', - $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', - $ F4.1, '), Y,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ', - $ 'Y,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK2. -* - END - SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) -* -* Tests ZTRMV, ZTBMV, ZTPMV, ZTRSV, ZTBSV and ZTPSV. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) -* .. Local Scalars .. - COMPLEX*16 TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, - $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME - CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS - CHARACTER*2 ICHD, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZMAKE, ZMVCH, ZTBMV, ZTBSV, ZTPMV, ZTPSV, - $ ZTRMV, ZTRSV -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'R' - BANDED = SNAME( 3: 3 ).EQ.'B' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 8 - ELSE IF( BANDED )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 7 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* Set up zero vector for ZMVCH. - DO 10 I = 1, NMAX - Z( I ) = ZERO - 10 CONTINUE -* - DO 110 IN = 1, NIDIM - N = IDIM( IN ) -* - IF( BANDED )THEN - NK = NKB - ELSE - NK = 1 - END IF - DO 100 IK = 1, NK - IF( BANDED )THEN - K = KB( IK ) - ELSE - K = N - 1 - END IF -* Set LDA to 1 more than minimum value if room. - IF( BANDED )THEN - LDA = K + 1 - ELSE - LDA = N - END IF - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF - NULL = N.LE.0 -* - DO 90 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 80 ICT = 1, 3 - TRANS = ICHT( ICT: ICT ) -* - DO 70 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, - $ NMAX, AA, LDA, K, K, RESET, TRANSL ) -* - DO 60 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, - $ ABS( INCX ), 0, N - 1, RESET, - $ TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - DIAGS = DIAG - NS = N - KS = K - DO 20 I = 1, LAA - AS( I ) = AA( I ) - 20 CONTINUE - LDAS = LDA - DO 30 I = 1, LX - XS( I ) = XX( I ) - 30 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTRMV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTBMV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTPMV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTRSV( UPLO, TRANS, DIAG, N, AA, LDA, - $ XX, INCX ) - ELSE IF( BANDED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, K, LDA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTBSV( UPLO, TRANS, DIAG, N, K, AA, - $ LDA, XX, INCX ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ UPLO, TRANS, DIAG, N, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZTPSV( UPLO, TRANS, DIAG, N, AA, XX, - $ INCX ) - END IF - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = TRANS.EQ.TRANSS - ISAME( 3 ) = DIAG.EQ.DIAGS - ISAME( 4 ) = NS.EQ.N - IF( FULL )THEN - ISAME( 5 ) = LZE( AS, AA, LAA ) - ISAME( 6 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 7 ) = LZE( XS, XX, LX ) - ELSE - ISAME( 7 ) = LZERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 8 ) = INCXS.EQ.INCX - ELSE IF( BANDED )THEN - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = LZE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 8 ) = LZE( XS, XX, LX ) - ELSE - ISAME( 8 ) = LZERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 9 ) = INCXS.EQ.INCX - ELSE IF( PACKED )THEN - ISAME( 5 ) = LZE( AS, AA, LAA ) - IF( NULL )THEN - ISAME( 6 ) = LZE( XS, XX, LX ) - ELSE - ISAME( 6 ) = LZERES( 'GE', ' ', 1, N, XS, - $ XX, ABS( INCX ) ) - END IF - ISAME( 7 ) = INCXS.EQ.INCX - END IF -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MV' )THEN -* -* Check the result. -* - CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, - $ INCX, ZERO, Z, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN -* -* Compute approximation to original vector. -* - DO 50 I = 1, N - Z( I ) = XX( 1 + ( I - 1 )* - $ ABS( INCX ) ) - XX( 1 + ( I - 1 )*ABS( INCX ) ) - $ = X( I ) - 50 CONTINUE - CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, Z, - $ INCX, ZERO, X, INCX, XT, G, - $ XX, EPS, ERR, FATAL, NOUT, - $ .FALSE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 120 - ELSE -* Avoid repeating tests with N.le.0. - GO TO 110 - END IF -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, - $ INCX - ELSE IF( BANDED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, - $ LDA, INCX - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', - $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), - $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', - $ I3, ', X,', I2, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK3. -* - END - SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests ZGERC and ZGERU. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, - $ NC, ND, NS - LOGICAL CONJ, NULL, RESET, SAME -* .. Local Arrays .. - COMPLEX*16 W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZGERC, ZGERU, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, DCONJG, MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. - CONJ = SNAME( 5: 5 ).EQ.'C' -* Define the number of arguments. - NARGS = 9 -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 120 IN = 1, NIDIM - N = IDIM( IN ) - ND = N/2 + 1 -* - DO 110 IM = 1, 2 - IF( IM.EQ.1 ) - $ M = MAX( N - ND, 0 ) - IF( IM.EQ.2 ) - $ M = MIN( N + ND, NMAX ) -* -* Set LDA to 1 more than minimum value if room. - LDA = M - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 100 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*M -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), - $ 0, M - 1, RESET, TRANSL ) - IF( M.GT.1 )THEN - X( M/2 ) = ZERO - XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO - END IF -* - DO 90 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, - $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, - $ ALPHA, INCX, INCY, LDA - IF( CONJ )THEN - IF( REWI ) - $ REWIND NTRA - CALL ZGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) - ELSE - IF( REWI ) - $ REWIND NTRA - CALL ZGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA, - $ LDA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9993 ) - FATAL = .TRUE. - GO TO 140 - END IF -* -* See what data changed inside subroutine. -* - ISAME( 1 ) = MS.EQ.M - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LZE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LZE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LZE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LZERES( 'GE', ' ', M, N, AS, AA, - $ LDA ) - END IF - ISAME( 9 ) = LDAS.EQ.LDA -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 140 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, M - Z( I ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, M - Z( I ) = X( M - I + 1 ) - 60 CONTINUE - END IF - DO 70 J = 1, N - IF( INCY.GT.0 )THEN - W( 1 ) = Y( J ) - ELSE - W( 1 ) = Y( N - J + 1 ) - END IF - IF( CONJ ) - $ W( 1 ) = DCONJG( W( 1 ) ) - CALL ZMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, - $ ONE, A( 1, J ), 1, YT, G, - $ AA( 1 + ( J - 1 )*LDA ), EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 130 - 70 CONTINUE - ELSE -* Avoid repeating tests with M.le.0 or N.le.0. - GO TO 110 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 150 -* - 130 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 140 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA -* - 150 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, - $ '), X,', I2, ', Y,', I2, ', A,', I3, ') ', - $ ' .' ) - 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK4. -* - END - SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests ZHER and ZHPR. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, TRANSL - DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS - INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, - $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - COMPLEX*16 W( 1 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHER, ZHPR, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DCONJG, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 7 - ELSE IF( PACKED )THEN - NARGS = 6 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 100 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 90 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 80 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 70 IA = 1, NALF - RALPHA = DBLE( ALF( IA ) ) - ALPHA = DCMPLX( RALPHA, RZERO ) - NULL = N.LE.0.OR.RALPHA.EQ.RZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, - $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - RALS = RALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ RALPHA, INCX, LDA - IF( REWI ) - $ REWIND NTRA - CALL ZHER( UPLO, N, RALPHA, XX, INCX, AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ RALPHA, INCX - IF( REWI ) - $ REWIND NTRA - CALL ZHPR( UPLO, N, RALPHA, XX, INCX, AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = RALS.EQ.RALPHA - ISAME( 4 ) = LZE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - IF( NULL )THEN - ISAME( 6 ) = LZE( AS, AA, LAA ) - ELSE - ISAME( 6 ) = LZERES( SNAME( 2: 3 ), UPLO, N, N, AS, - $ AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 7 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 40 I = 1, N - Z( I ) = X( I ) - 40 CONTINUE - ELSE - DO 50 I = 1, N - Z( I ) = X( N - I + 1 ) - 50 CONTINUE - END IF - JA = 1 - DO 60 J = 1, N - W( 1 ) = DCONJG( Z( J ) ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL ZMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, - $ 1, ONE, A( JJ, J ), 1, YT, G, - $ AA( JA ), EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 110 - 60 CONTINUE - ELSE -* Avoid repeating tests if N.le.0. - IF( N.LE.0 ) - $ GO TO 100 - END IF -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', - $ I2, ', A,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK5. -* - END - SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, - $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, - $ Z ) -* -* Tests ZHER2 and ZHPR2. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ HALF = ( 0.5D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), - $ XX( NMAX*INCMAX ), Y( NMAX ), - $ YS( NMAX*INCMAX ), YT( NMAX ), - $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ), INC( NINC ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, TRANSL - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, - $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, - $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER - CHARACTER*1 UPLO, UPLOS - CHARACTER*2 ICH -* .. Local Arrays .. - COMPLEX*16 W( 2 ) - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHER2, ZHPR2, ZMAKE, ZMVCH -* .. Intrinsic Functions .. - INTRINSIC ABS, DCONJG, MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'UL'/ -* .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'E' - PACKED = SNAME( 3: 3 ).EQ.'P' -* Define the number of arguments. - IF( FULL )THEN - NARGS = 9 - ELSE IF( PACKED )THEN - NARGS = 8 - END IF -* - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 140 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDA to 1 more than minimum value if room. - LDA = N - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 140 - IF( PACKED )THEN - LAA = ( N*( N + 1 ) )/2 - ELSE - LAA = LDA*N - END IF -* - DO 130 IC = 1, 2 - UPLO = ICH( IC: IC ) - UPPER = UPLO.EQ.'U' -* - DO 120 IX = 1, NINC - INCX = INC( IX ) - LX = ABS( INCX )*N -* -* Generate the vector X. -* - TRANSL = HALF - CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), - $ 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - X( N/2 ) = ZERO - XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 110 IY = 1, NINC - INCY = INC( IY ) - LY = ABS( INCY )*N -* -* Generate the vector Y. -* - TRANSL = ZERO - CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, - $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) - IF( N.GT.1 )THEN - Y( N/2 ) = ZERO - YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO - END IF -* - DO 100 IA = 1, NALF - ALPHA = ALF( IA ) - NULL = N.LE.0.OR.ALPHA.EQ.ZERO -* -* Generate the matrix A. -* - TRANSL = ZERO - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, - $ NMAX, AA, LDA, N - 1, N - 1, RESET, - $ TRANSL ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LX - XS( I ) = XX( I ) - 20 CONTINUE - INCXS = INCX - DO 30 I = 1, LY - YS( I ) = YY( I ) - 30 CONTINUE - INCYS = INCY -* -* Call the subroutine. -* - IF( FULL )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY, LDA - IF( REWI ) - $ REWIND NTRA - CALL ZHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA, LDA ) - ELSE IF( PACKED )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, - $ ALPHA, INCX, INCY - IF( REWI ) - $ REWIND NTRA - CALL ZHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, - $ AA ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 160 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLO.EQ.UPLOS - ISAME( 2 ) = NS.EQ.N - ISAME( 3 ) = ALS.EQ.ALPHA - ISAME( 4 ) = LZE( XS, XX, LX ) - ISAME( 5 ) = INCXS.EQ.INCX - ISAME( 6 ) = LZE( YS, YY, LY ) - ISAME( 7 ) = INCYS.EQ.INCY - IF( NULL )THEN - ISAME( 8 ) = LZE( AS, AA, LAA ) - ELSE - ISAME( 8 ) = LZERES( SNAME( 2: 3 ), UPLO, N, N, - $ AS, AA, LDA ) - END IF - IF( .NOT.PACKED )THEN - ISAME( 9 ) = LDAS.EQ.LDA - END IF -* -* If data was incorrectly changed, report and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 160 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( INCX.GT.0 )THEN - DO 50 I = 1, N - Z( I, 1 ) = X( I ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - Z( I, 1 ) = X( N - I + 1 ) - 60 CONTINUE - END IF - IF( INCY.GT.0 )THEN - DO 70 I = 1, N - Z( I, 2 ) = Y( I ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - Z( I, 2 ) = Y( N - I + 1 ) - 80 CONTINUE - END IF - JA = 1 - DO 90 J = 1, N - W( 1 ) = ALPHA*DCONJG( Z( J, 2 ) ) - W( 2 ) = DCONJG( ALPHA )*DCONJG( Z( J, 1 ) ) - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - CALL ZMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), - $ NMAX, W, 1, ONE, A( JJ, J ), 1, - $ YT, G, AA( JA ), EPS, ERR, FATAL, - $ NOUT, .TRUE. ) - IF( FULL )THEN - IF( UPPER )THEN - JA = JA + LDA - ELSE - JA = JA + LDA + 1 - END IF - ELSE - JA = JA + LJ - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and return. - IF( FATAL ) - $ GO TO 150 - 90 CONTINUE - ELSE -* Avoid repeating tests with N.le.0. - IF( N.LE.0 ) - $ GO TO 140 - END IF -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 170 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9995 )J -* - 160 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, - $ INCY, LDA - ELSE IF( PACKED )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY - END IF -* - 170 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), X,', I2, ', Y,', I2, ', AP) ', - $ ' .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', - $ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') ', - $ ' .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK6. -* - END - SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 2 Blas. -* Requires a special version of the error-handling routine XERBLA. -* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Local Scalars .. - COMPLEX*16 ALPHA, BETA - DOUBLE PRECISION RALPHA -* .. Local Arrays .. - COMPLEX*16 A( 1, 1 ), X( 1 ), Y( 1 ) -* .. External Subroutines .. - EXTERNAL CHKXER, ZGBMV, ZGEMV, ZGERC, ZGERU, ZHBMV, - $ ZHEMV, ZHER, ZHER2, ZHPMV, ZHPR, ZHPR2, ZTBMV, - $ ZTBSV, ZTPMV, ZTPSV, ZTRMV, ZTRSV -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90, 100, 110, 120, 130, 140, 150, 160, - $ 170 )ISNUM - 10 INFOT = 1 - CALL ZGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 20 INFOT = 1 - CALL ZGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 30 INFOT = 1 - CALL ZHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 40 INFOT = 1 - CALL ZHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 50 INFOT = 1 - CALL ZHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 60 INFOT = 1 - CALL ZTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 70 INFOT = 1 - CALL ZTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 80 INFOT = 1 - CALL ZTPMV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTPMV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTPMV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTPMV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTPMV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 90 INFOT = 1 - CALL ZTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 100 INFOT = 1 - CALL ZTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 110 INFOT = 1 - CALL ZTPSV( '/', 'N', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTPSV( 'U', '/', 'N', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTPSV( 'U', 'N', '/', 0, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTPSV( 'U', 'N', 'N', -1, A, X, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTPSV( 'U', 'N', 'N', 0, A, X, 0 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 120 INFOT = 1 - CALL ZGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 130 INFOT = 1 - CALL ZGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 140 INFOT = 1 - CALL ZHER( '/', 0, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHER( 'U', -1, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHER( 'U', 0, RALPHA, X, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER( 'U', 2, RALPHA, X, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 150 INFOT = 1 - CALL ZHPR( '/', 0, RALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHPR( 'U', -1, RALPHA, X, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHPR( 'U', 0, RALPHA, X, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 160 INFOT = 1 - CALL ZHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 180 - 170 INFOT = 1 - CALL ZHPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 180 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of ZCHKE. -* - END - SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, - $ KU, RESET, TRANSL ) -* -* Generates values for an M by N matrix A within the bandwidth -* defined by KL and KU. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - COMPLEX*16 ROGUE - PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) - DOUBLE PRECISION RROGUE - PARAMETER ( RROGUE = -1.0D10 ) -* .. Scalar Arguments .. - COMPLEX*16 TRANSL - INTEGER KL, KU, LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX*16 A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - COMPLEX*16 ZBEG - EXTERNAL ZBEG -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, MAX, MIN -* .. Executable Statements .. - GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'H' - TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - IF( ( I.LE.J.AND.J - I.LE.KU ).OR. - $ ( I.GE.J.AND.I - J.LE.KL ) )THEN - A( I, J ) = ZBEG( RESET ) + TRANSL - ELSE - A( I, J ) = ZERO - END IF - IF( I.NE.J )THEN - IF( SYM )THEN - A( J, I ) = DCONJG( A( I, J ) ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( SYM ) - $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO ) - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'GB' )THEN - DO 90 J = 1, N - DO 60 I1 = 1, KU + 1 - J - AA( I1 + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) - AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) - 70 CONTINUE - DO 80 I3 = I2, LDA - AA( I3 + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - 90 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN - DO 130 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 100 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 100 CONTINUE - DO 110 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 110 CONTINUE - DO 120 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 120 CONTINUE - IF( SYM )THEN - JJ = J + ( J - 1 )*LDA - AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) - END IF - 130 CONTINUE - ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN - DO 170 J = 1, N - IF( UPPER )THEN - KK = KL + 1 - IBEG = MAX( 1, KL + 2 - J ) - IF( UNIT )THEN - IEND = KL - ELSE - IEND = KL + 1 - END IF - ELSE - KK = 1 - IF( UNIT )THEN - IBEG = 2 - ELSE - IBEG = 1 - END IF - IEND = MIN( KL + 1, 1 + M - J ) - END IF - DO 140 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 140 CONTINUE - DO 150 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) - 150 CONTINUE - DO 160 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 160 CONTINUE - IF( SYM )THEN - JJ = KK + ( J - 1 )*LDA - AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) - END IF - 170 CONTINUE - ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN - IOFF = 0 - DO 190 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 180 I = IBEG, IEND - IOFF = IOFF + 1 - AA( IOFF ) = A( I, J ) - IF( I.EQ.J )THEN - IF( UNIT ) - $ AA( IOFF ) = ROGUE - IF( SYM ) - $ AA( IOFF ) = DCMPLX( DBLE( AA( IOFF ) ), RROGUE ) - END IF - 180 CONTINUE - 190 CONTINUE - END IF - RETURN -* -* End of ZMAKE. -* - END - SUBROUTINE ZMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, - $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO, RONE - PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - DOUBLE PRECISION EPS, ERR - INTEGER INCX, INCY, M, N, NMAX, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX*16 A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) - DOUBLE PRECISION G( * ) -* .. Local Scalars .. - COMPLEX*16 C - DOUBLE PRECISION ERRI - INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL - LOGICAL CTRAN, TRAN -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, SQRT -* .. Statement Functions .. - DOUBLE PRECISION ABS1 -* .. Statement Function definitions .. - ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) ) -* .. Executable Statements .. - TRAN = TRANS.EQ.'T' - CTRAN = TRANS.EQ.'C' - IF( TRAN.OR.CTRAN )THEN - ML = N - NL = M - ELSE - ML = M - NL = N - END IF - IF( INCX.LT.0 )THEN - KX = NL - INCXL = -1 - ELSE - KX = 1 - INCXL = 1 - END IF - IF( INCY.LT.0 )THEN - KY = ML - INCYL = -1 - ELSE - KY = 1 - INCYL = 1 - END IF -* -* Compute expected result in YT using data in A, X and Y. -* Compute gauges in G. -* - IY = KY - DO 40 I = 1, ML - YT( IY ) = ZERO - G( IY ) = RZERO - JX = KX - IF( TRAN )THEN - DO 10 J = 1, NL - YT( IY ) = YT( IY ) + A( J, I )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 10 CONTINUE - ELSE IF( CTRAN )THEN - DO 20 J = 1, NL - YT( IY ) = YT( IY ) + DCONJG( A( J, I ) )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 20 CONTINUE - ELSE - DO 30 J = 1, NL - YT( IY ) = YT( IY ) + A( I, J )*X( JX ) - G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) - JX = JX + INCXL - 30 CONTINUE - END IF - YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) - G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) - IY = IY + INCYL - 40 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 50 I = 1, ML - ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS - IF( G( I ).NE.RZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.RONE ) - $ GO TO 60 - 50 CONTINUE -* If the loop completes, all results are at least half accurate. - GO TO 80 -* -* Report fatal error. -* - 60 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 70 I = 1, ML - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, YT( I ), - $ YY( 1 + ( I - 1 )*ABS( INCY ) ) - ELSE - WRITE( NOUT, FMT = 9998 )I, - $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) - END IF - 70 CONTINUE -* - 80 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RE', - $ 'SULT COMPUTED RESULT' ) - 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) -* -* End of ZMVCH. -* - END - LOGICAL FUNCTION LZE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - COMPLEX*16 RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LZE = .TRUE. - GO TO 30 - 20 CONTINUE - LZE = .FALSE. - 30 RETURN -* -* End of LZE. -* - END - LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE', 'HE' or 'HP'. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX*16 AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'HE' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LZERES = .TRUE. - GO TO 80 - 70 CONTINUE - LZERES = .FALSE. - 80 RETURN -* -* End of LZERES. -* - END - COMPLEX*16 FUNCTION ZBEG( RESET ) -* -* Generates complex numbers as pairs of random numbers uniformly -* distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, J, MI, MJ -* .. Save statement .. - SAVE I, IC, J, MI, MJ -* .. Intrinsic Functions .. - INTRINSIC DCMPLX -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - MJ = 457 - I = 7 - J = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I or J is bounded between 1 and 999. -* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. -* If initial I or J = 4 or 8, the period will be 25. -* If initial I or J = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I or J -* in 6. -* - IC = IC + 1 - 10 I = I*MI - J = J*MJ - I = I - 1000*( I/1000 ) - J = J - 1000*( J/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 ) - RETURN -* -* End of ZBEG. -* - END - DOUBLE PRECISION FUNCTION DDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. Executable Statements .. - DDIFF = X - Y - RETURN -* -* End of DDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 2 BLAS -* routines. -* -* XERBLA is an error handler for the Level 2 BLAS routines. -* -* It is called by the Level 2 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 2 Blas. -* -* -- Written on 10-August-1987. -* Richard Hanson, Sandia National Labs. -* Jeremy Du Croz, NAG Central Office. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/testing/zblat3.dat b/eigen/blas/testing/zblat3.dat deleted file mode 100644 index ede516f..0000000 --- a/eigen/blas/testing/zblat3.dat +++ /dev/null @@ -1,23 +0,0 @@ -'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. diff --git a/eigen/blas/testing/zblat3.f b/eigen/blas/testing/zblat3.f deleted file mode 100644 index 59ca241..0000000 --- a/eigen/blas/testing/zblat3.f +++ /dev/null @@ -1,3502 +0,0 @@ -*> \brief \b ZBLAT3 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* PROGRAM ZBLAT3 -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Test program for the COMPLEX*16 Level 3 Blas. -*> -*> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 9 records -*> are read using the format ( A6, L2 ). An annotated example of a data -*> file can be obtained by deleting the first 3 characters from the -*> following 23 lines: -*> 'zblat3.out' NAME OF SUMMARY OUTPUT FILE -*> 6 UNIT NUMBER OF SUMMARY FILE -*> 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) -*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. -*> F LOGICAL FLAG, T TO STOP ON FAILURES. -*> T LOGICAL FLAG, T TO TEST ERROR EXITS. -*> 16.0 THRESHOLD VALUE OF TEST RATIO -*> 6 NUMBER OF VALUES OF N -*> 0 1 2 3 5 9 VALUES OF N -*> 3 NUMBER OF VALUES OF ALPHA -*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA -*> 3 NUMBER OF VALUES OF BETA -*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -*> ZGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHERK T PUT F FOR NO TEST. SAME COLUMNS. -*> ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. -*> ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> -*> -*> Further Details -*> =============== -*> -*> See: -*> -*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. -*> A Set of Level 3 Basic Linear Algebra Subprograms. -*> -*> Technical Memorandum No.88 (Revision 1), Mathematics and -*> Computer Science Division, Argonne National Laboratory, 9700 -*> South Cass Avenue, Argonne, Illinois 60439, US. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers -*> can be run multiple times without deleting generated -*> output files (susan) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date April 2012 -* -*> \ingroup complex16_blas_testing -* -* ===================================================================== - PROGRAM ZBLAT3 -* -* -- 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 NIN - PARAMETER ( NIN = 5 ) - INTEGER NSUBS - PARAMETER ( NSUBS = 9 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) - INTEGER NMAX - PARAMETER ( NMAX = 65 ) - INTEGER NIDMAX, NALMAX, NBEMAX - PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) -* .. Local Scalars .. - DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA - LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, - $ TSTERR - CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET - CHARACTER*32 SNAPS, SUMMRY -* .. Local Arrays .. - COMPLEX*16 AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), - $ ALF( NALMAX ), AS( NMAX*NMAX ), - $ BB( NMAX*NMAX ), BET( NBEMAX ), - $ BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ W( 2*NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDMAX ) - LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) -* .. External Functions .. - DOUBLE PRECISION DDIFF - LOGICAL LZE - EXTERNAL DDIFF, LZE -* .. External Subroutines .. - EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHKE, ZMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Data statements .. - DATA SNAMES/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ', - $ 'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K', - $ 'ZSYR2K'/ -* .. Executable Statements .. -* -* Read name and unit number for summary output file and open file. -* - READ( NIN, FMT = * )SUMMRY - READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) - NOUTC = NOUT -* -* Read name and unit number for snapshot output file and open file. -* - READ( NIN, FMT = * )SNAPS - READ( NIN, FMT = * )NTRA - TRACE = NTRA.GE.0 - IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) - END IF -* Read the flag that directs rewinding of the snapshot file. - READ( NIN, FMT = * )REWI - REWI = REWI.AND.TRACE -* Read the flag that directs stopping on any failure. - READ( NIN, FMT = * )SFATAL -* Read the flag that indicates whether error exits are to be tested. - READ( NIN, FMT = * )TSTERR -* Read the threshold value of the test ratio - READ( NIN, FMT = * )THRESH -* -* Read and check the parameter values for the tests. -* -* Values of N - READ( NIN, FMT = * )NIDIM - IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN - WRITE( NOUT, FMT = 9997 )'N', NIDMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) - DO 10 I = 1, NIDIM - IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN - WRITE( NOUT, FMT = 9996 )NMAX - GO TO 220 - END IF - 10 CONTINUE -* Values of ALPHA - READ( NIN, FMT = * )NALF - IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN - WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) -* Values of BETA - READ( NIN, FMT = * )NBET - IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN - WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX - GO TO 220 - END IF - READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) -* -* Report values of parameters. -* - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) - WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) - WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) - IF( .NOT.TSTERR )THEN - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9984 ) - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9999 )THRESH - WRITE( NOUT, FMT = * ) -* -* Read names of subroutines and flags which indicate -* whether they are to be tested. -* - DO 20 I = 1, NSUBS - LTEST( I ) = .FALSE. - 20 CONTINUE - 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT - DO 40 I = 1, NSUBS - IF( SNAMET.EQ.SNAMES( I ) ) - $ GO TO 50 - 40 CONTINUE - WRITE( NOUT, FMT = 9990 )SNAMET - STOP - 50 LTEST( I ) = LTESTT - GO TO 30 -* - 60 CONTINUE - CLOSE ( NIN ) -* -* Compute EPS (the machine precision). -* - EPS = EPSILON(RZERO) - WRITE( NOUT, FMT = 9998 )EPS -* -* Check the reliability of ZMMCH using exact data. -* - N = MIN( 32, NMAX ) - DO 100 J = 1, N - DO 90 I = 1, N - AB( I, J ) = MAX( I - J + 1, 0 ) - 90 CONTINUE - AB( J, NMAX + 1 ) = J - AB( 1, NMAX + J ) = J - C( J, 1 ) = ZERO - 100 CONTINUE - DO 110 J = 1, N - CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 - 110 CONTINUE -* CC holds the exact result. On exit from ZMMCH CT holds -* the result computed by ZMMCH. - TRANSA = 'N' - TRANSB = 'N' - CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'C' - CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - DO 120 J = 1, N - AB( J, NMAX + 1 ) = N - J + 1 - AB( 1, NMAX + J ) = N - J + 1 - 120 CONTINUE - DO 130 J = 1, N - CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - - $ ( ( J + 1 )*J*( J - 1 ) )/3 - 130 CONTINUE - TRANSA = 'C' - TRANSB = 'N' - CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF - TRANSB = 'C' - CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, - $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, - $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) - SAME = LZE( CC, CT, N ) - IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN - WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR - STOP - END IF -* -* Test each subroutine in turn. -* - DO 200 ISNUM = 1, NSUBS - WRITE( NOUT, FMT = * ) - IF( .NOT.LTEST( ISNUM ) )THEN -* Subprogram is not to be tested. - WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) - ELSE - SRNAMT = SNAMES( ISNUM ) -* Test error exits. - IF( TSTERR )THEN - CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) - WRITE( NOUT, FMT = * ) - END IF -* Test computations. - INFOT = 0 - OK = .TRUE. - FATAL = .FALSE. - GO TO ( 140, 150, 150, 160, 160, 170, 170, - $ 180, 180 )ISNUM -* Test ZGEMM, 01. - 140 CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test ZHEMM, 02, ZSYMM, 03. - 150 CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test ZTRMM, 04, ZTRSM, 05. - 160 CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, - $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) - GO TO 190 -* Test ZHERK, 06, ZSYRK, 07. - 170 CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, - $ CC, CS, CT, G ) - GO TO 190 -* Test ZHER2K, 08, ZSYR2K, 09. - 180 CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, - $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, - $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) - GO TO 190 -* - 190 IF( FATAL.AND.SFATAL ) - $ GO TO 210 - END IF - 200 CONTINUE - WRITE( NOUT, FMT = 9986 ) - GO TO 230 -* - 210 CONTINUE - WRITE( NOUT, FMT = 9985 ) - GO TO 230 -* - 220 CONTINUE - WRITE( NOUT, FMT = 9991 ) -* - 230 CONTINUE - IF( TRACE ) - $ CLOSE ( NTRA ) - CLOSE ( NOUT ) - STOP -* - 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', - $ 'S THAN', F8.2 ) - 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) - 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', - $ 'THAN ', I2 ) - 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) - 9995 FORMAT( ' TESTS OF THE COMPLEX*16 LEVEL 3 BLAS', //' THE F', - $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) - 9994 FORMAT( ' FOR N ', 9I6 ) - 9993 FORMAT( ' FOR ALPHA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9992 FORMAT( ' FOR BETA ', - $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) - 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', - $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', - $ 'ESTS ABANDONED *******' ) - 9989 FORMAT( ' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', - $ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', A1, - $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', - $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', - $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', - $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) - 9986 FORMAT( /' END OF TESTS' ) - 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) - 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) -* -* End of ZBLAT3. -* - END - SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests ZGEMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BLS - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, - $ MA, MB, MS, N, NA, NARGS, NB, NC, NS - LOGICAL NULL, RESET, SAME, TRANA, TRANB - CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB - CHARACTER*3 ICH -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZGEMM, ZMAKE, ZMMCH -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICH/'NTC'/ -* .. Executable Statements .. -* - NARGS = 13 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 110 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICA = 1, 3 - TRANSA = ICH( ICA: ICA ) - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' -* - IF( TRANA )THEN - MA = K - NA = M - ELSE - MA = M - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICB = 1, 3 - TRANSB = ICH( ICB: ICB ) - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' -* - IF( TRANB )THEN - MB = N - NB = K - ELSE - MB = K - NB = N - END IF -* Set LDB to 1 more than minimum value if room. - LDB = MB - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 70 - LBB = LDB*NB -* -* Generate the matrix B. -* - CALL ZMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, - $ LDB, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, - $ CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - TRANAS = TRANSA - TRANBS = TRANSB - MS = M - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, - $ BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZGEMM( TRANSA, TRANSB, M, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = TRANSA.EQ.TRANAS - ISAME( 2 ) = TRANSB.EQ.TRANBS - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = KS.EQ.K - ISAME( 6 ) = ALS.EQ.ALPHA - ISAME( 7 ) = LZE( AS, AA, LAA ) - ISAME( 8 ) = LDAS.EQ.LDA - ISAME( 9 ) = LZE( BS, BB, LBB ) - ISAME( 10 ) = LDBS.EQ.LDB - ISAME( 11 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 12 ) = LZE( CS, CC, LCC ) - ELSE - ISAME( 12 ) = LZERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 13 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report -* and return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - CALL ZMMCH( TRANSA, TRANSB, M, N, K, - $ ALPHA, A, NMAX, B, NMAX, BETA, - $ C, NMAX, CT, G, CC, LDC, EPS, - $ ERR, FATAL, NOUT, .TRUE. ) - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 120 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, - $ ALPHA, LDA, LDB, BETA, LDC -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', - $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, - $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK1. -* - END - SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests ZHEMM and ZSYMM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BLS - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, - $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, - $ NARGS, NC, NS - LOGICAL CONJ, LEFT, NULL, RESET, SAME - CHARACTER*1 SIDE, SIDES, UPLO, UPLOS - CHARACTER*2 ICHS, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHEMM, ZMAKE, ZMMCH, ZSYMM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHS/'LR'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 90 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = M - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 90 - LCC = LDC*N - NULL = N.LE.0.OR.M.LE.0 -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 90 - LBB = LDB*N -* -* Generate the matrix B. -* - CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, - $ ZERO ) -* - DO 80 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' -* - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* -* Generate the hermitian or symmetric matrix A. -* - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX, - $ AA, LDA, RESET, ZERO ) -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 50 IB = 1, NBET - BETA = BET( IB ) -* -* Generate the matrix C. -* - CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - MS = M - NS = N - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - BLS = BETA - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, - $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - IF( CONJ )THEN - CALL ZHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) - ELSE - CALL ZSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 110 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = MS.EQ.M - ISAME( 4 ) = NS.EQ.N - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LZE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LZE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - ISAME( 10 ) = BLS.EQ.BETA - IF( NULL )THEN - ISAME( 11 ) = LZE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LZERES( 'GE', ' ', M, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 110 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL ZMMCH( 'N', 'N', M, N, M, ALPHA, A, - $ NMAX, B, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL ZMMCH( 'N', 'N', M, N, N, ALPHA, B, - $ NMAX, A, NMAX, BETA, C, NMAX, - $ CT, G, CC, LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 120 -* - 110 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC -* - 120 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, - $ ',', F4.1, '), C,', I3, ') .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK2. -* - END - SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, - $ B, BB, BS, CT, G, C ) -* -* Tests ZTRMM and ZTRSM. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CT( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS - DOUBLE PRECISION ERR, ERRMAX - INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, - $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, - $ NS - LOGICAL LEFT, NULL, RESET, SAME - CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, - $ UPLOS - CHARACTER*2 ICHD, ICHS, ICHU - CHARACTER*3 ICHT -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZMAKE, ZMMCH, ZTRMM, ZTRSM -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ -* .. Executable Statements .. -* - NARGS = 11 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* Set up zero matrix for ZMMCH. - DO 20 J = 1, NMAX - DO 10 I = 1, NMAX - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* - DO 140 IM = 1, NIDIM - M = IDIM( IM ) -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDB to 1 more than minimum value if room. - LDB = M - IF( LDB.LT.NMAX ) - $ LDB = LDB + 1 -* Skip tests if not enough room. - IF( LDB.GT.NMAX ) - $ GO TO 130 - LBB = LDB*N - NULL = M.LE.0.OR.N.LE.0 -* - DO 120 ICS = 1, 2 - SIDE = ICHS( ICS: ICS ) - LEFT = SIDE.EQ.'L' - IF( LEFT )THEN - NA = M - ELSE - NA = N - END IF -* Set LDA to 1 more than minimum value if room. - LDA = NA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 130 - LAA = LDA*NA -* - DO 110 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) -* - DO 100 ICT = 1, 3 - TRANSA = ICHT( ICT: ICT ) -* - DO 90 ICD = 1, 2 - DIAG = ICHD( ICD: ICD ) -* - DO 80 IA = 1, NALF - ALPHA = ALF( IA ) -* -* Generate the matrix A. -* - CALL ZMAKE( 'TR', UPLO, DIAG, NA, NA, A, - $ NMAX, AA, LDA, RESET, ZERO ) -* -* Generate the matrix B. -* - CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX, - $ BB, LDB, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the -* subroutine. -* - SIDES = SIDE - UPLOS = UPLO - TRANAS = TRANSA - DIAGS = DIAG - MS = M - NS = N - ALS = ALPHA - DO 30 I = 1, LAA - AS( I ) = AA( I ) - 30 CONTINUE - LDAS = LDA - DO 40 I = 1, LBB - BS( I ) = BB( I ) - 40 CONTINUE - LDBS = LDB -* -* Call the subroutine. -* - IF( SNAME( 4: 5 ).EQ.'MM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL ZTRMM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, - $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, - $ LDA, LDB - IF( REWI ) - $ REWIND NTRA - CALL ZTRSM( SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, AA, LDA, BB, LDB ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9994 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = SIDES.EQ.SIDE - ISAME( 2 ) = UPLOS.EQ.UPLO - ISAME( 3 ) = TRANAS.EQ.TRANSA - ISAME( 4 ) = DIAGS.EQ.DIAG - ISAME( 5 ) = MS.EQ.M - ISAME( 6 ) = NS.EQ.N - ISAME( 7 ) = ALS.EQ.ALPHA - ISAME( 8 ) = LZE( AS, AA, LAA ) - ISAME( 9 ) = LDAS.EQ.LDA - IF( NULL )THEN - ISAME( 10 ) = LZE( BS, BB, LBB ) - ELSE - ISAME( 10 ) = LZERES( 'GE', ' ', M, N, BS, - $ BB, LDB ) - END IF - ISAME( 11 ) = LDBS.EQ.LDB -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 50 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 50 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'MM' )THEN -* -* Check the result. -* - IF( LEFT )THEN - CALL ZMMCH( TRANSA, 'N', M, N, M, - $ ALPHA, A, NMAX, B, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL ZMMCH( 'N', TRANSA, M, N, N, - $ ALPHA, B, NMAX, A, NMAX, - $ ZERO, C, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN -* -* Compute approximation to original -* matrix. -* - DO 70 J = 1, N - DO 60 I = 1, M - C( I, J ) = BB( I + ( J - 1 )* - $ LDB ) - BB( I + ( J - 1 )*LDB ) = ALPHA* - $ B( I, J ) - 60 CONTINUE - 70 CONTINUE -* - IF( LEFT )THEN - CALL ZMMCH( TRANSA, 'N', M, N, M, - $ ONE, A, NMAX, C, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - ELSE - CALL ZMMCH( 'N', TRANSA, M, N, N, - $ ONE, C, NMAX, A, NMAX, - $ ZERO, B, NMAX, CT, G, - $ BB, LDB, EPS, ERR, - $ FATAL, NOUT, .FALSE. ) - END IF - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 150 - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* - 140 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, - $ N, ALPHA, LDA, LDB -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', - $ ' .' ) - 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK3. -* - END - SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) -* -* Tests ZHERK and ZSYRK. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RONE, RZERO - PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), - $ AS( NMAX*NMAX ), B( NMAX, NMAX ), - $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), - $ C( NMAX, NMAX ), CC( NMAX*NMAX ), - $ CS( NMAX*NMAX ), CT( NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BETS - DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, - $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, - $ NARGS, NC, NS - LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS - CHARACTER*2 ICHT, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHERK, ZMAKE, ZMMCH, ZSYRK -* .. Intrinsic Functions .. - INTRINSIC DCMPLX, MAX, DBLE -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NC'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 10 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 100 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 100 - LCC = LDC*N -* - DO 90 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 80 ICT = 1, 2 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'C' - IF( TRAN.AND..NOT.CONJ ) - $ TRANS = 'T' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 80 - LAA = LDA*NA -* -* Generate the matrix A. -* - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) -* - DO 70 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 60 IA = 1, NALF - ALPHA = ALF( IA ) - IF( CONJ )THEN - RALPHA = DBLE( ALPHA ) - ALPHA = DCMPLX( RALPHA, RZERO ) - END IF -* - DO 50 IB = 1, NBET - BETA = BET( IB ) - IF( CONJ )THEN - RBETA = DBLE( BETA ) - BETA = DCMPLX( RBETA, RZERO ) - END IF - NULL = N.LE.0 - IF( CONJ ) - $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. - $ RZERO ).AND.RBETA.EQ.RONE ) -* -* Generate the matrix C. -* - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, - $ NMAX, CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - IF( CONJ )THEN - RALS = RALPHA - ELSE - ALS = ALPHA - END IF - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - IF( CONJ )THEN - RBETS = RBETA - ELSE - BETS = BETA - END IF - DO 20 I = 1, LCC - CS( I ) = CC( I ) - 20 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( CONJ )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, RALPHA, LDA, RBETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZHERK( UPLO, TRANS, N, K, RALPHA, AA, - $ LDA, RBETA, CC, LDC ) - ELSE - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZSYRK( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 120 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - IF( CONJ )THEN - ISAME( 5 ) = RALS.EQ.RALPHA - ELSE - ISAME( 5 ) = ALS.EQ.ALPHA - END IF - ISAME( 6 ) = LZE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - IF( CONJ )THEN - ISAME( 8 ) = RBETS.EQ.RBETA - ELSE - ISAME( 8 ) = BETS.EQ.BETA - END IF - IF( NULL )THEN - ISAME( 9 ) = LZE( CS, CC, LCC ) - ELSE - ISAME( 9 ) = LZERES( SNAME( 2: 3 ), UPLO, N, - $ N, CS, CC, LDC ) - END IF - ISAME( 10 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 30 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 30 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 120 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( CONJ )THEN - TRANST = 'C' - ELSE - TRANST = 'T' - END IF - JC = 1 - DO 40 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - CALL ZMMCH( TRANST, 'N', LJ, 1, K, - $ ALPHA, A( 1, JJ ), NMAX, - $ A( 1, J ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - ELSE - CALL ZMMCH( 'N', TRANST, LJ, 1, K, - $ ALPHA, A( JJ, 1 ), NMAX, - $ A( J, 1 ), NMAX, BETA, - $ C( JJ, J ), NMAX, CT, G, - $ CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 110 - 40 CONTINUE - END IF -* - 50 CONTINUE -* - 60 CONTINUE -* - 70 CONTINUE -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 130 -* - 110 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 120 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( CONJ )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, RALPHA, - $ LDA, RBETA, LDC - ELSE - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, BETA, LDC - END IF -* - 130 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', - $ ' .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, - $ '), C,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK4. -* - END - SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, - $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) -* -* Tests ZHER2K and ZSYR2K. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION RONE, RZERO - PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 ) -* .. Scalar Arguments .. - DOUBLE PRECISION EPS, THRESH - INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA - LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME -* .. Array Arguments .. - COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), - $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), - $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), - $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), - $ W( 2*NMAX ) - DOUBLE PRECISION G( NMAX ) - INTEGER IDIM( NIDIM ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, ALS, BETA, BETS - DOUBLE PRECISION ERR, ERRMAX, RBETA, RBETS - INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, - $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, - $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER - CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS - CHARACTER*2 ICHT, ICHU -* .. Local Arrays .. - LOGICAL ISAME( 13 ) -* .. External Functions .. - LOGICAL LZE, LZERES - EXTERNAL LZE, LZERES -* .. External Subroutines .. - EXTERNAL ZHER2K, ZMAKE, ZMMCH, ZSYR2K -* .. Intrinsic Functions .. - INTRINSIC DCMPLX, DCONJG, MAX, DBLE -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Data statements .. - DATA ICHT/'NC'/, ICHU/'UL'/ -* .. Executable Statements .. - CONJ = SNAME( 2: 3 ).EQ.'HE' -* - NARGS = 12 - NC = 0 - RESET = .TRUE. - ERRMAX = RZERO -* - DO 130 IN = 1, NIDIM - N = IDIM( IN ) -* Set LDC to 1 more than minimum value if room. - LDC = N - IF( LDC.LT.NMAX ) - $ LDC = LDC + 1 -* Skip tests if not enough room. - IF( LDC.GT.NMAX ) - $ GO TO 130 - LCC = LDC*N -* - DO 120 IK = 1, NIDIM - K = IDIM( IK ) -* - DO 110 ICT = 1, 2 - TRANS = ICHT( ICT: ICT ) - TRAN = TRANS.EQ.'C' - IF( TRAN.AND..NOT.CONJ ) - $ TRANS = 'T' - IF( TRAN )THEN - MA = K - NA = N - ELSE - MA = N - NA = K - END IF -* Set LDA to 1 more than minimum value if room. - LDA = MA - IF( LDA.LT.NMAX ) - $ LDA = LDA + 1 -* Skip tests if not enough room. - IF( LDA.GT.NMAX ) - $ GO TO 110 - LAA = LDA*NA -* -* Generate the matrix A. -* - IF( TRAN )THEN - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, - $ LDA, RESET, ZERO ) - ELSE - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, - $ RESET, ZERO ) - END IF -* -* Generate the matrix B. -* - LDB = LDA - LBB = LAA - IF( TRAN )THEN - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), - $ 2*NMAX, BB, LDB, RESET, ZERO ) - ELSE - CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), - $ NMAX, BB, LDB, RESET, ZERO ) - END IF -* - DO 100 ICU = 1, 2 - UPLO = ICHU( ICU: ICU ) - UPPER = UPLO.EQ.'U' -* - DO 90 IA = 1, NALF - ALPHA = ALF( IA ) -* - DO 80 IB = 1, NBET - BETA = BET( IB ) - IF( CONJ )THEN - RBETA = DBLE( BETA ) - BETA = DCMPLX( RBETA, RZERO ) - END IF - NULL = N.LE.0 - IF( CONJ ) - $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. - $ ZERO ).AND.RBETA.EQ.RONE ) -* -* Generate the matrix C. -* - CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, - $ NMAX, CC, LDC, RESET, ZERO ) -* - NC = NC + 1 -* -* Save every datum before calling the subroutine. -* - UPLOS = UPLO - TRANSS = TRANS - NS = N - KS = K - ALS = ALPHA - DO 10 I = 1, LAA - AS( I ) = AA( I ) - 10 CONTINUE - LDAS = LDA - DO 20 I = 1, LBB - BS( I ) = BB( I ) - 20 CONTINUE - LDBS = LDB - IF( CONJ )THEN - RBETS = RBETA - ELSE - BETS = BETA - END IF - DO 30 I = 1, LCC - CS( I ) = CC( I ) - 30 CONTINUE - LDCS = LDC -* -* Call the subroutine. -* - IF( CONJ )THEN - IF( TRACE ) - $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, RBETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZHER2K( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BB, LDB, RBETA, CC, LDC ) - ELSE - IF( TRACE ) - $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, - $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC - IF( REWI ) - $ REWIND NTRA - CALL ZSYR2K( UPLO, TRANS, N, K, ALPHA, AA, - $ LDA, BB, LDB, BETA, CC, LDC ) - END IF -* -* Check if error-exit was taken incorrectly. -* - IF( .NOT.OK )THEN - WRITE( NOUT, FMT = 9992 ) - FATAL = .TRUE. - GO TO 150 - END IF -* -* See what data changed inside subroutines. -* - ISAME( 1 ) = UPLOS.EQ.UPLO - ISAME( 2 ) = TRANSS.EQ.TRANS - ISAME( 3 ) = NS.EQ.N - ISAME( 4 ) = KS.EQ.K - ISAME( 5 ) = ALS.EQ.ALPHA - ISAME( 6 ) = LZE( AS, AA, LAA ) - ISAME( 7 ) = LDAS.EQ.LDA - ISAME( 8 ) = LZE( BS, BB, LBB ) - ISAME( 9 ) = LDBS.EQ.LDB - IF( CONJ )THEN - ISAME( 10 ) = RBETS.EQ.RBETA - ELSE - ISAME( 10 ) = BETS.EQ.BETA - END IF - IF( NULL )THEN - ISAME( 11 ) = LZE( CS, CC, LCC ) - ELSE - ISAME( 11 ) = LZERES( 'HE', UPLO, N, N, CS, - $ CC, LDC ) - END IF - ISAME( 12 ) = LDCS.EQ.LDC -* -* If data was incorrectly changed, report and -* return. -* - SAME = .TRUE. - DO 40 I = 1, NARGS - SAME = SAME.AND.ISAME( I ) - IF( .NOT.ISAME( I ) ) - $ WRITE( NOUT, FMT = 9998 )I - 40 CONTINUE - IF( .NOT.SAME )THEN - FATAL = .TRUE. - GO TO 150 - END IF -* - IF( .NOT.NULL )THEN -* -* Check the result column by column. -* - IF( CONJ )THEN - TRANST = 'C' - ELSE - TRANST = 'T' - END IF - JJAB = 1 - JC = 1 - DO 70 J = 1, N - IF( UPPER )THEN - JJ = 1 - LJ = J - ELSE - JJ = J - LJ = N - J + 1 - END IF - IF( TRAN )THEN - DO 50 I = 1, K - W( I ) = ALPHA*AB( ( J - 1 )*2* - $ NMAX + K + I ) - IF( CONJ )THEN - W( K + I ) = DCONJG( ALPHA )* - $ AB( ( J - 1 )*2* - $ NMAX + I ) - ELSE - W( K + I ) = ALPHA* - $ AB( ( J - 1 )*2* - $ NMAX + I ) - END IF - 50 CONTINUE - CALL ZMMCH( TRANST, 'N', LJ, 1, 2*K, - $ ONE, AB( JJAB ), 2*NMAX, W, - $ 2*NMAX, BETA, C( JJ, J ), - $ NMAX, CT, G, CC( JC ), LDC, - $ EPS, ERR, FATAL, NOUT, - $ .TRUE. ) - ELSE - DO 60 I = 1, K - IF( CONJ )THEN - W( I ) = ALPHA*DCONJG( AB( ( K + - $ I - 1 )*NMAX + J ) ) - W( K + I ) = DCONJG( ALPHA* - $ AB( ( I - 1 )*NMAX + - $ J ) ) - ELSE - W( I ) = ALPHA*AB( ( K + I - 1 )* - $ NMAX + J ) - W( K + I ) = ALPHA* - $ AB( ( I - 1 )*NMAX + - $ J ) - END IF - 60 CONTINUE - CALL ZMMCH( 'N', 'N', LJ, 1, 2*K, ONE, - $ AB( JJ ), NMAX, W, 2*NMAX, - $ BETA, C( JJ, J ), NMAX, CT, - $ G, CC( JC ), LDC, EPS, ERR, - $ FATAL, NOUT, .TRUE. ) - END IF - IF( UPPER )THEN - JC = JC + LDC - ELSE - JC = JC + LDC + 1 - IF( TRAN ) - $ JJAB = JJAB + 2*NMAX - END IF - ERRMAX = MAX( ERRMAX, ERR ) -* If got really bad answer, report and -* return. - IF( FATAL ) - $ GO TO 140 - 70 CONTINUE - END IF -* - 80 CONTINUE -* - 90 CONTINUE -* - 100 CONTINUE -* - 110 CONTINUE -* - 120 CONTINUE -* - 130 CONTINUE -* -* Report result. -* - IF( ERRMAX.LT.THRESH )THEN - WRITE( NOUT, FMT = 9999 )SNAME, NC - ELSE - WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX - END IF - GO TO 160 -* - 140 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9995 )J -* - 150 CONTINUE - WRITE( NOUT, FMT = 9996 )SNAME - IF( CONJ )THEN - WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, RBETA, LDC - ELSE - WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, - $ LDA, LDB, BETA, LDC - END IF -* - 160 CONTINUE - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', - $ 'S)' ) - 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', - $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', - $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, - $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, - $ ', C,', I3, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), - $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, - $ ',', F4.1, '), C,', I3, ') .' ) - 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', - $ '******' ) -* -* End of ZCHK5. -* - END - SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) -* -* Tests the error exits from the Level 3 Blas. -* Requires a special version of the error-handling routine XERBLA. -* A, B and C should not need to be defined. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca) -* 3-19-92: Fix argument 12 in calls to ZSYMM and ZHEMM -* with INFOT = 9 (eca) -* 10-9-00: Declared INTRINSIC DCMPLX (susan) -* -* .. Scalar Arguments .. - INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT -* .. Scalars in Common .. - INTEGER INFOT, NOUTC - LOGICAL LERR, OK -* .. Parameters .. - REAL ONE, TWO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) -* .. Local Scalars .. - COMPLEX*16 ALPHA, BETA - DOUBLE PRECISION RALPHA, RBETA -* .. Local Arrays .. - COMPLEX*16 A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) -* .. External Subroutines .. - EXTERNAL ZGEMM, ZHEMM, ZHER2K, ZHERK, CHKXER, ZSYMM, - $ ZSYR2K, ZSYRK, ZTRMM, ZTRSM -* .. Intrinsic Functions .. - INTRINSIC DCMPLX -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUTC, OK, LERR -* .. Executable Statements .. -* OK is set to .FALSE. by the special version of XERBLA or by CHKXER -* if anything is wrong. - OK = .TRUE. -* LERR is set to .TRUE. by the special version of XERBLA each time -* it is called, and is then tested and re-set by CHKXER. - LERR = .FALSE. -* -* Initialize ALPHA, BETA, RALPHA, and RBETA. -* - ALPHA = DCMPLX( ONE, -ONE ) - BETA = DCMPLX( TWO, -TWO ) - RALPHA = ONE - RBETA = TWO -* - GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90 )ISNUM - 10 INFOT = 1 - CALL ZGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL ZGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 1 - CALL ZGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 13 - CALL ZGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 20 INFOT = 1 - CALL ZHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 30 INFOT = 1 - CALL ZSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 40 INFOT = 1 - CALL ZTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 50 INFOT = 1 - CALL ZTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 6 - CALL ZTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 11 - CALL ZTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 60 INFOT = 1 - CALL ZHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 70 INFOT = 1 - CALL ZSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 10 - CALL ZSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 80 INFOT = 1 - CALL ZHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 - 90 INFOT = 1 - CALL ZSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 9 - CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - INFOT = 12 - CALL ZSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) - CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* - 100 IF( OK )THEN - WRITE( NOUT, FMT = 9999 )SRNAMT - ELSE - WRITE( NOUT, FMT = 9998 )SRNAMT - END IF - RETURN -* - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', - $ '**' ) -* -* End of ZCHKE. -* - END - SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, - $ TRANSL ) -* -* Generates values for an M by N matrix A. -* Stores the values in the array AA in the data structure required -* by the routine, with unwanted elements set to rogue value. -* -* TYPE is 'GE', 'HE', 'SY' or 'TR'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), - $ ONE = ( 1.0D0, 0.0D0 ) ) - COMPLEX*16 ROGUE - PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0D0 ) - DOUBLE PRECISION RROGUE - PARAMETER ( RROGUE = -1.0D10 ) -* .. Scalar Arguments .. - COMPLEX*16 TRANSL - INTEGER LDA, M, N, NMAX - LOGICAL RESET - CHARACTER*1 DIAG, UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX*16 A( NMAX, * ), AA( * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J, JJ - LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER -* .. External Functions .. - COMPLEX*16 ZBEG - EXTERNAL ZBEG -* .. Intrinsic Functions .. - INTRINSIC DCMPLX, DCONJG, DBLE -* .. Executable Statements .. - GEN = TYPE.EQ.'GE' - HER = TYPE.EQ.'HE' - SYM = TYPE.EQ.'SY' - TRI = TYPE.EQ.'TR' - UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' - UNIT = TRI.AND.DIAG.EQ.'U' -* -* Generate data in array A. -* - DO 20 J = 1, N - DO 10 I = 1, M - IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) - $ THEN - A( I, J ) = ZBEG( RESET ) + TRANSL - IF( I.NE.J )THEN -* Set some elements to zero - IF( N.GT.3.AND.J.EQ.N/2 ) - $ A( I, J ) = ZERO - IF( HER )THEN - A( J, I ) = DCONJG( A( I, J ) ) - ELSE IF( SYM )THEN - A( J, I ) = A( I, J ) - ELSE IF( TRI )THEN - A( J, I ) = ZERO - END IF - END IF - END IF - 10 CONTINUE - IF( HER ) - $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO ) - IF( TRI ) - $ A( J, J ) = A( J, J ) + ONE - IF( UNIT ) - $ A( J, J ) = ONE - 20 CONTINUE -* -* Store elements in array AS in data structure required by routine. -* - IF( TYPE.EQ.'GE' )THEN - DO 50 J = 1, N - DO 30 I = 1, M - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 30 CONTINUE - DO 40 I = M + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 40 CONTINUE - 50 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN - DO 90 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IF( UNIT )THEN - IEND = J - 1 - ELSE - IEND = J - END IF - ELSE - IF( UNIT )THEN - IBEG = J + 1 - ELSE - IBEG = J - END IF - IEND = N - END IF - DO 60 I = 1, IBEG - 1 - AA( I + ( J - 1 )*LDA ) = ROGUE - 60 CONTINUE - DO 70 I = IBEG, IEND - AA( I + ( J - 1 )*LDA ) = A( I, J ) - 70 CONTINUE - DO 80 I = IEND + 1, LDA - AA( I + ( J - 1 )*LDA ) = ROGUE - 80 CONTINUE - IF( HER )THEN - JJ = J + ( J - 1 )*LDA - AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) - END IF - 90 CONTINUE - END IF - RETURN -* -* End of ZMAKE. -* - END - SUBROUTINE ZMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, - $ NOUT, MV ) -* -* Checks the results of the computational tests. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) - DOUBLE PRECISION RZERO, RONE - PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - DOUBLE PRECISION EPS, ERR - INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT - LOGICAL FATAL, MV - CHARACTER*1 TRANSA, TRANSB -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ CC( LDCC, * ), CT( * ) - DOUBLE PRECISION G( * ) -* .. Local Scalars .. - COMPLEX*16 CL - DOUBLE PRECISION ERRI - INTEGER I, J, K - LOGICAL CTRANA, CTRANB, TRANA, TRANB -* .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DCONJG, MAX, DBLE, SQRT -* .. Statement Functions .. - DOUBLE PRECISION ABS1 -* .. Statement Function definitions .. - ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( DIMAG( CL ) ) -* .. Executable Statements .. - TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' - TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' - CTRANA = TRANSA.EQ.'C' - CTRANB = TRANSB.EQ.'C' -* -* Compute expected result, one column at a time, in CT using data -* in A, B and C. -* Compute gauges in G. -* - DO 220 J = 1, N -* - DO 10 I = 1, M - CT( I ) = ZERO - G( I ) = RZERO - 10 CONTINUE - IF( .NOT.TRANA.AND..NOT.TRANB )THEN - DO 30 K = 1, KK - DO 20 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( K, J ) - G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( TRANA.AND..NOT.TRANB )THEN - IF( CTRANA )THEN - DO 50 K = 1, KK - DO 40 I = 1, M - CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( K, J ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( K, J ) ) - 40 CONTINUE - 50 CONTINUE - ELSE - DO 70 K = 1, KK - DO 60 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( K, J ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( K, J ) ) - 60 CONTINUE - 70 CONTINUE - END IF - ELSE IF( .NOT.TRANA.AND.TRANB )THEN - IF( CTRANB )THEN - DO 90 K = 1, KK - DO 80 I = 1, M - CT( I ) = CT( I ) + A( I, K )*DCONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( I, K ) )* - $ ABS1( B( J, K ) ) - 80 CONTINUE - 90 CONTINUE - ELSE - DO 110 K = 1, KK - DO 100 I = 1, M - CT( I ) = CT( I ) + A( I, K )*B( J, K ) - G( I ) = G( I ) + ABS1( A( I, K ) )* - $ ABS1( B( J, K ) ) - 100 CONTINUE - 110 CONTINUE - END IF - ELSE IF( TRANA.AND.TRANB )THEN - IF( CTRANA )THEN - IF( CTRANB )THEN - DO 130 K = 1, KK - DO 120 I = 1, M - CT( I ) = CT( I ) + DCONJG( A( K, I ) )* - $ DCONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 120 CONTINUE - 130 CONTINUE - ELSE - DO 150 K = 1, KK - DO 140 I = 1, M - CT( I ) = CT( I ) + DCONJG( A( K, I ) )* - $ B( J, K ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE - IF( CTRANB )THEN - DO 170 K = 1, KK - DO 160 I = 1, M - CT( I ) = CT( I ) + A( K, I )* - $ DCONJG( B( J, K ) ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 190 K = 1, KK - DO 180 I = 1, M - CT( I ) = CT( I ) + A( K, I )*B( J, K ) - G( I ) = G( I ) + ABS1( A( K, I ) )* - $ ABS1( B( J, K ) ) - 180 CONTINUE - 190 CONTINUE - END IF - END IF - END IF - DO 200 I = 1, M - CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) - G( I ) = ABS1( ALPHA )*G( I ) + - $ ABS1( BETA )*ABS1( C( I, J ) ) - 200 CONTINUE -* -* Compute the error ratio for this result. -* - ERR = ZERO - DO 210 I = 1, M - ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS - IF( G( I ).NE.RZERO ) - $ ERRI = ERRI/G( I ) - ERR = MAX( ERR, ERRI ) - IF( ERR*SQRT( EPS ).GE.RONE ) - $ GO TO 230 - 210 CONTINUE -* - 220 CONTINUE -* -* If the loop completes, all results are at least half accurate. - GO TO 250 -* -* Report fatal error. -* - 230 FATAL = .TRUE. - WRITE( NOUT, FMT = 9999 ) - DO 240 I = 1, M - IF( MV )THEN - WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) - ELSE - WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) - END IF - 240 CONTINUE - IF( N.GT.1 ) - $ WRITE( NOUT, FMT = 9997 )J -* - 250 CONTINUE - RETURN -* - 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', - $ 'F ACCURATE *******', /' EXPECTED RE', - $ 'SULT COMPUTED RESULT' ) - 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) - 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) -* -* End of ZMMCH. -* - END - LOGICAL FUNCTION LZE( RI, RJ, LR ) -* -* Tests if two arrays are identical. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LR -* .. Array Arguments .. - COMPLEX*16 RI( * ), RJ( * ) -* .. Local Scalars .. - INTEGER I -* .. Executable Statements .. - DO 10 I = 1, LR - IF( RI( I ).NE.RJ( I ) ) - $ GO TO 20 - 10 CONTINUE - LZE = .TRUE. - GO TO 30 - 20 CONTINUE - LZE = .FALSE. - 30 RETURN -* -* End of LZE. -* - END - LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA ) -* -* Tests if selected elements in two arrays are equal. -* -* TYPE is 'GE' or 'HE' or 'SY'. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER LDA, M, N - CHARACTER*1 UPLO - CHARACTER*2 TYPE -* .. Array Arguments .. - COMPLEX*16 AA( LDA, * ), AS( LDA, * ) -* .. Local Scalars .. - INTEGER I, IBEG, IEND, J - LOGICAL UPPER -* .. Executable Statements .. - UPPER = UPLO.EQ.'U' - IF( TYPE.EQ.'GE' )THEN - DO 20 J = 1, N - DO 10 I = M + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 10 CONTINUE - 20 CONTINUE - ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY' )THEN - DO 50 J = 1, N - IF( UPPER )THEN - IBEG = 1 - IEND = J - ELSE - IBEG = J - IEND = N - END IF - DO 30 I = 1, IBEG - 1 - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 30 CONTINUE - DO 40 I = IEND + 1, LDA - IF( AA( I, J ).NE.AS( I, J ) ) - $ GO TO 70 - 40 CONTINUE - 50 CONTINUE - END IF -* - LZERES = .TRUE. - GO TO 80 - 70 CONTINUE - LZERES = .FALSE. - 80 RETURN -* -* End of LZERES. -* - END - COMPLEX*16 FUNCTION ZBEG( RESET ) -* -* Generates complex numbers as pairs of random numbers uniformly -* distributed between -0.5 and 0.5. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - LOGICAL RESET -* .. Local Scalars .. - INTEGER I, IC, J, MI, MJ -* .. Save statement .. - SAVE I, IC, J, MI, MJ -* .. Intrinsic Functions .. - INTRINSIC DCMPLX -* .. Executable Statements .. - IF( RESET )THEN -* Initialize local variables. - MI = 891 - MJ = 457 - I = 7 - J = 7 - IC = 0 - RESET = .FALSE. - END IF -* -* The sequence of values of I or J is bounded between 1 and 999. -* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. -* If initial I or J = 4 or 8, the period will be 25. -* If initial I or J = 5, the period will be 10. -* IC is used to break up the period by skipping 1 value of I or J -* in 6. -* - IC = IC + 1 - 10 I = I*MI - J = J*MJ - I = I - 1000*( I/1000 ) - J = J - 1000*( J/1000 ) - IF( IC.GE.5 )THEN - IC = 0 - GO TO 10 - END IF - ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 ) - RETURN -* -* End of ZBEG. -* - END - DOUBLE PRECISION FUNCTION DDIFF( X, Y ) -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. Executable Statements .. - DDIFF = X - Y - RETURN -* -* End of DDIFF. -* - END - SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* -* Tests whether XERBLA has detected an error when it should. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Executable Statements .. - IF( .NOT.LERR )THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT - OK = .FALSE. - END IF - LERR = .FALSE. - RETURN -* - 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) -* -* End of CHKXER. -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* This is a special version of XERBLA to be used only as part of -* the test program for testing error exits from the Level 3 BLAS -* routines. -* -* XERBLA is an error handler for the Level 3 BLAS routines. -* -* It is called by the Level 3 BLAS routines if an input parameter is -* invalid. -* -* Auxiliary routine for test program for Level 3 Blas. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. Scalars in Common .. - INTEGER INFOT, NOUT - LOGICAL LERR, OK - CHARACTER*6 SRNAMT -* .. Common blocks .. - COMMON /INFOC/INFOT, NOUT, OK, LERR - COMMON /SRNAMC/SRNAMT -* .. Executable Statements .. - LERR = .TRUE. - IF( INFO.NE.INFOT )THEN - IF( INFOT.NE.0 )THEN - WRITE( NOUT, FMT = 9999 )INFO, INFOT - ELSE - WRITE( NOUT, FMT = 9997 )INFO - END IF - OK = .FALSE. - END IF - IF( SRNAME.NE.SRNAMT )THEN - WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT - OK = .FALSE. - END IF - RETURN -* - 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', - $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) - 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, - $ ' *******' ) -* -* End of XERBLA -* - END - diff --git a/eigen/blas/xerbla.cpp b/eigen/blas/xerbla.cpp deleted file mode 100644 index c373e86..0000000 --- a/eigen/blas/xerbla.cpp +++ /dev/null @@ -1,23 +0,0 @@ - -#include <stdio.h> - -#if (defined __GNUC__) && (!defined __MINGW32__) && (!defined __CYGWIN__) -#define EIGEN_WEAK_LINKING __attribute__ ((weak)) -#else -#define EIGEN_WEAK_LINKING -#endif - -#ifdef __cplusplus -extern "C" -{ -#endif - -EIGEN_WEAK_LINKING int xerbla_(const char * msg, int *info, int) -{ - printf("Eigen BLAS ERROR #%i: %s\n", *info, msg ); - return 0; -} - -#ifdef __cplusplus -} -#endif |