[sdpb] 44/233: Removed own mpack, now using mpack library; initialized some quantities for free variable elimination
Tobias Hansen
thansen at moszumanska.debian.org
Thu Mar 9 04:06:16 UTC 2017
This is an automated email from the git hooks/post-receive script.
thansen pushed a commit to branch master
in repository sdpb.
commit 230e5cd6ee81afe841ec3e29f39e7096d1a91329
Author: David Simmons-Duffin <dsd at neptune.sns.ias.edu>
Date: Sat Aug 2 00:22:09 2014 -0400
Removed own mpack, now using mpack library; initialized some quantities for free variable elimination
---
Makefile | 23 +--
main.cpp | 90 ++++++++++-
mpack/Mlsame.cpp | 80 ----------
mpack/Mutils.cpp | 174 ---------------------
mpack/Mxerbla.cpp | 49 ------
mpack/Raxpy.cpp | 99 ------------
mpack/Rcopy.cpp | 95 ------------
mpack/Rdot.cpp | 99 ------------
mpack/Rgemm.cpp | 231 ----------------------------
mpack/Rgemv.cpp | 177 ---------------------
mpack/Rger.cpp | 130 ----------------
mpack/Rlae2.cpp | 110 --------------
mpack/Rlaev2.cpp | 159 -------------------
mpack/Rlamch.cpp | 235 ----------------------------
mpack/Rlanst.cpp | 121 ---------------
mpack/Rlansy.cpp | 149 ------------------
mpack/Rlapy2.cpp | 90 -----------
mpack/Rlarf.cpp | 94 ------------
mpack/Rlarfb.cpp | 393 -----------------------------------------------
mpack/Rlarfg.cpp | 121 ---------------
mpack/Rlarft.cpp | 149 ------------------
mpack/Rlartg.cpp | 155 -------------------
mpack/Rlascl.cpp | 216 --------------------------
mpack/Rlaset.cpp | 105 -------------
mpack/Rlasr.cpp | 289 -----------------------------------
mpack/Rlasrt.cpp | 79 ----------
mpack/Rlassq.cpp | 95 ------------
mpack/Rlatrd.cpp | 167 --------------------
mpack/Rnrm2.cpp | 102 -------------
mpack/Rorg2l.cpp | 117 --------------
mpack/Rorg2r.cpp | 120 ---------------
mpack/Rorgql.cpp | 177 ---------------------
mpack/Rorgqr.cpp | 177 ---------------------
mpack/Rorgtr.cpp | 157 -------------------
mpack/Rpotf2.cpp | 139 -----------------
mpack/Rpotrf.cpp | 156 -------------------
mpack/Rrot.cpp | 99 ------------
mpack/Rrotg.cpp | 103 -------------
mpack/Rscal.cpp | 86 -----------
mpack/Rsteqr.cpp | 423 ---------------------------------------------------
mpack/Rsterf.cpp | 339 -----------------------------------------
mpack/Rswap.cpp | 98 ------------
mpack/Rsyev.cpp | 180 ----------------------
mpack/Rsymv.cpp | 183 ----------------------
mpack/Rsyr2.cpp | 156 -------------------
mpack/Rsyr2k.cpp | 246 ------------------------------
mpack/Rsyrk.cpp | 230 ----------------------------
mpack/Rsytd2.cpp | 151 ------------------
mpack/Rsytrd.cpp | 187 -----------------------
mpack/Rtrmm.cpp | 283 ----------------------------------
mpack/Rtrmv.cpp | 189 -----------------------
mpack/Rtrsm.cpp | 310 -------------------------------------
mpack/Rtrsv.cpp | 187 -----------------------
mpack/iMlaenv.cpp | 291 -----------------------------------
mpack/mblas_gmp.h | 96 ------------
mpack/mlapack_gmp.h | 92 -----------
mpack/mpack_config.h | 72 ---------
mpack/mutils_gmp.h | 76 ---------
58 files changed, 90 insertions(+), 9106 deletions(-)
diff --git a/Makefile b/Makefile
index aac06f6..c9f1e27 100755
--- a/Makefile
+++ b/Makefile
@@ -1,27 +1,10 @@
-OBJECTS = main.o tinyxml2.o mpack/Rrotg.o mpack/Rrot.o mpack/Rdot.o \
- mpack/Rtrsm.o mpack/Rsyrk.o mpack/Raxpy.o \
- mpack/Rgemm.o mpack/Rtrmm.o mpack/Rtrsv.o \
- mpack/iMlaenv.o mpack/Rlamch.o mpack/Rlascl.o \
- mpack/Rsytrd.o mpack/Rsterf.o mpack/Rorgtr.o \
- mpack/Rlatrd.o mpack/Rsyr2k.o mpack/Rsytd2.o \
- mpack/Rlanst.o mpack/Rlae2.o mpack/Rlapy2.o \
- mpack/Rlasrt.o mpack/Rorgql.o mpack/Rorgqr.o \
- mpack/Rsymv.o mpack/Rlarfg.o mpack/Rsyr2.o \
- mpack/Rlassq.o mpack/Rorg2l.o mpack/Rlarft.o \
- mpack/Rlarfb.o mpack/Rorg2r.o mpack/Rnrm2.o \
- mpack/Rlarf.o mpack/Rger.o mpack/Rpotrf.o \
- mpack/Mxerbla.o mpack/Rpotf2.o mpack/Mlsame.o \
- mpack/Rscal.o mpack/Rcopy.o mpack/Rgemv.o \
- mpack/Rtrmv.o mpack/Rsteqr.o mpack/Rlaset.o \
- mpack/Rlaev2.o mpack/Rlasr.o mpack/Rlartg.o \
- mpack/Rswap.o mpack/Rsyev.o mpack/Rlansy.o \
- mpack/Mutils.o
-HEADERS = mpack/mblas_gmp.h mpack/mlapack_gmp.h mpack/mpack_config.h mpack/mutils_gmp.h types.h tinyxml2.h
+OBJECTS = main.o tinyxml2.o
+HEADERS = types.h tinyxml2.h
SOURCES = $(OJBECTS:.o=.cpp)
RESULT = sdp-bootstrap
CC = g++
-CFLAGS = -g -O2 -Wall -ansi -L/home/dsd/lib -I./mpack -I/home/dsd/include -I/home/dsd/include/boost -fopenmp
+CFLAGS = -g -O2 -Wall -ansi -L/home/dsd/lib -I/home/dsd/include/mpack -I/home/dsd/include -I/home/dsd/include/boost -fopenmp
RM = rm -f
.SUFFIXES: .cpp .o
diff --git a/main.cpp b/main.cpp
index 9e37dff..f5df7fa 100644
--- a/main.cpp
+++ b/main.cpp
@@ -166,7 +166,7 @@ class Matrix {
}
}
- void transpose() {
+ void transposeInplace() {
assert (rows == cols);
for (int c = 0; c < cols; c++) {
for (int r = 0; r < c; r++) {
@@ -229,6 +229,16 @@ ostream& operator<<(ostream& os, const Matrix& a) {
return os;
}
+// B := A^T
+void transpose(const Matrix &A, Matrix &B) {
+ assert(A.cols == B.rows);
+ assert(A.rows == B.cols);
+
+ for (int n = 0; n < A.cols; n++)
+ for (int m = 0; m < A.rows; m++)
+ B.elt(n,m) = A.elt(m,n);
+}
+
// C := alpha*A*B + beta*C
//
void matrixScaleMultiplyAdd(Real alpha, Matrix &A, Matrix &B, Real beta, Matrix &C) {
@@ -345,6 +355,28 @@ Real frobeniusProductOfSums(const Matrix &X, const Matrix &dX,
return result;
}
+void LUDecomposition(Matrix &A, vector<mpackint> &ipiv) {
+ int dim = A.rows;
+ assert(A.cols == dim);
+
+ mpackint info;
+ Rgetrf(dim, dim, &A.elements[0], dim, &ipiv[0], &info);
+ cout << info << endl;
+ assert(info == 0);
+}
+
+void solveWithLUDecomposition(Matrix &LU, vector<mpackint> &ipiv, Real *B, int bcols, int ldb) {
+ mpackint info;
+ Rgetrs("NoTranspose", LU.rows, bcols, &LU.elements[0], LU.rows, &ipiv[0], B, ldb, &info);
+ assert(info == 0);
+}
+
+void solveWithLUDecompositionTranspose(Matrix &LU, vector<mpackint> &ipiv, Real *B, int bcols, int ldb) {
+ mpackint info;
+ Rgetrs("Transpose", LU.rows, bcols, &LU.elements[0], LU.rows, &ipiv[0], B, ldb, &info);
+ assert(info == 0);
+}
+
// L (lower triangular) such that A = L L^T
// Inputs:
// - A : dim x dim symmetric matrix
@@ -1444,6 +1476,15 @@ public:
// Schur complement for computing search direction
Matrix SchurComplementCholesky;
+ // For free variable elimination
+ Matrix DBLU;
+ vector<mpackint> DBLUipiv;
+ Matrix E;
+ Matrix EWork;
+ Vector g;
+ Real c0Tilde;
+ Vector cTilde;
+
// New variables for Schur complement calculation
Matrix schurComplementP;
Matrix schurComplementQ;
@@ -1480,6 +1521,12 @@ public:
dualResidues(x),
PrimalResidues(X),
SchurComplementCholesky(sdp.numConstraints(), sdp.numConstraints()),
+ DBLU(sdp.objective.size(), sdp.objective.size()),
+ DBLUipiv(sdp.objective.size()),
+ E(sdp.numConstraints() - sdp.objective.size(), sdp.objective.size()),
+ EWork(E.cols, E.rows),
+ g(sdp.objective.size()),
+ cTilde(sdp.numConstraints() - sdp.objective.size()),
schurComplementP(sdp.polMatrixValues.cols, sdp.polMatrixValues.cols),
schurComplementQ(schurComplementP),
schurComplementY(sdp.polMatrixValues.rows),
@@ -1503,6 +1550,43 @@ public:
eigenvaluesWorkspace.push_back(Vector(X.blocks[b].rows));
QRWorkspace.push_back(Vector(3*X.blocks[b].rows - 1));
}
+
+ // Computations needed for free variable elimination
+
+ // LU Decomposition of D_B
+ for (int n = 0; n < DBLU.cols; n++)
+ for (int m = 0; m < DBLU.rows; m++)
+ DBLU.elt(m,n) = sdp.polMatrixValues.elt(m,n);
+ LUDecomposition(DBLU, DBLUipiv);
+
+ // Compute E = - D_N D_B^{-1}
+ int nonBasicStart = sdp.objective.size();
+ // EWork = -D_N^T
+ for (int p = 0; p < EWork.cols; p++)
+ for (int n = 0; n < EWork.rows; n++)
+ EWork.elt(n, p) = -sdp.polMatrixValues.elt(p + nonBasicStart, n);
+ // EWork = D_B^{-1 T} EWork = -D_B^{-1 T} D_N^T
+ solveWithLUDecompositionTranspose(DBLU, DBLUipiv, &EWork.elements[0], EWork.cols, EWork.rows);
+ // E = EWork^T
+ transpose(EWork, E);
+
+ // g = -D_B^{-T} f
+ for (unsigned int n = 0; n < g.size(); n++)
+ g[n] = -sdp.objective[n];
+ solveWithLUDecompositionTranspose(DBLU, DBLUipiv, &g[0], 1, g.size());
+
+ // c0Tilde = - c_B^T g
+ c0Tilde = 0;
+ for (unsigned int n = 0; n < g.size(); n++)
+ c0Tilde -= g[n]*sdp.affineConstants[n];
+
+ // cTilde = c_N + E c_B
+ for (unsigned int p = 0; p < cTilde.size(); p++) {
+ cTilde[p] = sdp.affineConstants[p + nonBasicStart];
+ for (int n = 0; n < E.cols; n++)
+ cTilde[p] += E.elt(p, n) * sdp.affineConstants[n];
+ }
+
}
void initialize(const SDPSolverParameters ¶meters);
@@ -1797,7 +1881,7 @@ void eigenvaluesViaQR(Matrix &A, Vector &workspace, Vector &eigenvalues) {
mpackint info;
mpackint workSize = workspace.size();
- Rsyev("NoEigenvectors", "LowerTriangular", A.rows, &A.elements[0], A.rows, &eigenvalues[0], &workspace[0], &workSize, &info);
+ Rsyev("NoEigenvectors", "LowerTriangular", A.rows, &A.elements[0], A.rows, &eigenvalues[0], &workspace[0], workSize, &info);
assert(info == 0);
}
@@ -2307,7 +2391,7 @@ void testCholeskyUpdate() {
choleskyDecomposition(A, L);
choleskyUpdate(L, U);
LT = L;
- LT.transpose();
+ LT.transposeInplace();
matrixMultiply(V, VT, B);
B += A;
diff --git a/mpack/Mlsame.cpp b/mpack/Mlsame.cpp
deleted file mode 100644
index bc8f500..0000000
--- a/mpack/Mlsame.cpp
+++ /dev/null
@@ -1,80 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Mlsame_gmp.cpp,v 1.3 2009/09/17 00:59:04 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/lsame.f
-Mlsame_gmp returns 1 if CA is the same letter as CB regardless of case.
-*/
-
-#include <ctype.h>
-
-int
-Mlsame_gmp(const char *a, const char *b)
-{
- if (toupper(*a) == toupper(*b))
- return 1;
- return 0;
-}
diff --git a/mpack/Mutils.cpp b/mpack/Mutils.cpp
deleted file mode 100644
index 8e483c0..0000000
--- a/mpack/Mutils.cpp
+++ /dev/null
@@ -1,174 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Mutils.cpp,v 1.7 2009/09/16 08:32:46 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <math.h>
-#define ___MPACK_BUILD_WITH_GMP___
-
-mpf_class
-mpf_approx_log2(mpf_class x)
-{
-#if defined ___MPACK_BUILD_WITH_GMP___
- double d;
- double ln2_app;
- signed long int exp;
-
- d = mpf_get_d_2exp(&exp, x.get_mpf_t());
- ln2_app = (double)exp + log10(d) / log10(2);
- return ln2_app;
-#endif
-#if defined ___MPACK_BUILD_WITH_QD___
- return log10(x) / (qd_real::_log2/qd_real::_log10);
-#endif
-#if defined ___MPACK_BUILD_WITH_DD___
- return log10(x) / (dd_real::_log2/dd_real::_log10);
-#endif
-}
-
-mpf_class
-mpf_approx_log(mpf_class x)
-{
-#if defined ___MPACK_BUILD_WITH_GMP___
- double d;
- double ln_app;
- signed long int exp;
-
- d = mpf_get_d_2exp(&exp, x.get_mpf_t());
- ln_app = (double)exp * log (2.0) + log(d);
- return ln_app;
-#endif
-#if defined ___MPACK_BUILD_WITH_QD___
- return log(x);
-#endif
-#if defined ___MPACK_BUILD_WITH_DD___
- return log(x);
-#endif
-}
-
-mpf_class
-mpf_approx_log10(mpf_class x)
-{
-#if defined ___MPACK_BUILD_WITH_GMP___
- double d;
- double ln10_app;
- signed long int exp;
-
- d = mpf_get_d_2exp(&exp, x.get_mpf_t());
- ln10_app = (double)exp * log10(2.0) + log10(d);
- return ln10_app;
-#endif
-#if defined ___MPACK_BUILD_WITH_QD___
- return log10(x);
-#endif
-#if defined ___MPACK_BUILD_WITH_DD___
- return log10(x);
-#endif
-}
-
-mpf_class
-mpf_approx_pow(mpf_class x, mpf_class y)
-{
-#if defined ___MPACK_BUILD_WITH_GMP___
- mpf_class mtemp1, mtemp2;
- mtemp1 = y * mpf_approx_log(x);
- mtemp2 = mpf_approx_exp(mtemp1);
- return mtemp2;
-#endif
-#if defined ___MPACK_BUILD_WITH_QD___
- return pow(x, y);
-#endif
-#if defined ___MPACK_BUILD_WITH_DD___
- return pow(x, y);
-#endif
-}
-
-mpf_class
-mpf_approx_cos(mpf_class x)
-{
-#if defined ___MPACK_BUILD_WITH_GMP___
- mpf_class mtemp1;
- mtemp1 = cos(x.get_d());
- return mtemp1;
-#endif
-#if defined ___MPACK_BUILD_WITH_QD___
- return cos(x);
-#endif
-#if defined ___MPACK_BUILD_WITH_DD___
- return cos(x);
-#endif
-}
-
-mpf_class
-mpf_approx_sin(mpf_class x)
-{
-#if defined ___MPACK_BUILD_WITH_GMP___
- mpf_class mtemp1;
- mtemp1 = sin(x.get_d());
- return mtemp1;
-#endif
-#if defined ___MPACK_BUILD_WITH_QD___
- return sin(x);
-#endif
-#if defined ___MPACK_BUILD_WITH_DD___
- return sin(x);
-#endif
-}
-
-mpf_class
-mpf_approx_exp(mpf_class x)
-{
-#if defined ___MPACK_BUILD_WITH_GMP___
- mpf_class mtemp1;
- mtemp1 = exp(x.get_d());
- return mtemp1;
-#endif
-#if defined ___MPACK_BUILD_WITH_QD___
- return exp(x);
-#endif
-#if defined ___MPACK_BUILD_WITH_DD___
- return exp(x);
-#endif
-}
-
-mpf_class
-mpf_approx_pi()
-{
-#if defined ___MPACK_BUILD_WITH_GMP___
- mpf_class mtemp1;
- mtemp1 = M_PI;
- return mtemp1;
-#endif
-#if defined ___MPACK_BUILD_WITH_QD___
- return qd_real::_pi;
-#endif
-#if defined ___MPACK_BUILD_WITH_DD___
- return dd_real::_pi;
-#endif
-}
diff --git a/mpack/Mxerbla.cpp b/mpack/Mxerbla.cpp
deleted file mode 100644
index b0e0afc..0000000
--- a/mpack/Mxerbla.cpp
+++ /dev/null
@@ -1,49 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Mxerbla_gmp.cpp,v 1.3 2009/09/17 00:59:04 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Based on http://www.netlib.org/blas/xerbla.f
-Mxerbla_gmp is an error handler for the Mlapack routines.
-*/
-
-#include <mblas_gmp.h>
-
-#if !defined __MPACK_ERRNO__
-#define __MPACK_ERRNO__
-int mpack_errno;
-#endif
-
-void
-Mxerbla_gmp(const char *srname, int info)
-{
- fprintf(stderr,
- " ** On entry to %s parameter number %2d had an illegal value\n",
- srname, info);
- mpack_errno = info;
- return;
-}
diff --git a/mpack/Raxpy.cpp b/mpack/Raxpy.cpp
deleted file mode 100644
index 52a9a64..0000000
--- a/mpack/Raxpy.cpp
+++ /dev/null
@@ -1,99 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Raxpy.cpp,v 1.2 2009/09/12 21:39:52 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/daxpy.f
-*/
-
-#include <mblas_gmp.h>
-
-void
-Raxpy(mpackint n, mpf_class da, mpf_class * dx, mpackint incx, mpf_class * dy,
- mpackint incy)
-{
- mpf_class Zero = 0.0;
-
- if (n <= 0)
- return;
- if (da == Zero)
- return;
-
- mpackint ix = 0;
-
- mpackint iy = 0;
-
- if (incx < 0)
- ix = (-n + 1) * incx;
- if (incy < 0)
- iy = (-n + 1) * incy;
-
- for (mpackint i = 0; i < n; i++) {
- dy[iy] = dy[iy] + da * dx[ix];
- ix = ix + incx;
- iy = iy + incy;
- }
- return;
-}
diff --git a/mpack/Rcopy.cpp b/mpack/Rcopy.cpp
deleted file mode 100644
index 5609a6c..0000000
--- a/mpack/Rcopy.cpp
+++ /dev/null
@@ -1,95 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rcopy.cpp,v 1.2 2009/09/12 21:39:52 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dcopy.f
-Rcopy copies a vector, x, to a vector, y.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rcopy(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy, mpackint incy)
-{
- mpackint ix = 0;
-
- mpackint iy = 0;
-
- if (n <= 0)
- return;
-
- if (incx < 0)
- ix = (-n + 1) * incx;
- if (incy < 0)
- iy = (-n + 1) * incy;
-
- for (mpackint i = 0; i < n; i++) {
- dy[iy] = dx[ix];
- ix = ix + incx;
- iy = iy + incy;
- }
- return;
-}
diff --git a/mpack/Rdot.cpp b/mpack/Rdot.cpp
deleted file mode 100644
index a6e58f9..0000000
--- a/mpack/Rdot.cpp
+++ /dev/null
@@ -1,99 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rdot.cpp,v 1.2 2009/09/12 21:39:52 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/ddot.f
-Rdot forms the dot product of two vectors.
-*/
-
-#include <mblas_gmp.h>
-
-mpf_class
-Rdot(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy, mpackint incy)
-{
- mpackint ix = 0;
-
- mpackint iy = 0;
-
- mpf_class temp;
-
- temp = 0.0;
-
- if (n <= 0)
- return temp;
-
- if (incx < 0)
- ix = (-n + 1) * incx;
- if (incy < 0)
- iy = (-n + 1) * incy;
-
- for (mpackint i = 0; i < n; i++) {
- temp = temp + dx[ix] * dy[iy];
- ix = ix + incx;
- iy = iy + incy;
- }
- return temp;
-}
diff --git a/mpack/Rgemm.cpp b/mpack/Rgemm.cpp
deleted file mode 100644
index 657381a..0000000
--- a/mpack/Rgemm.cpp
+++ /dev/null
@@ -1,231 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rgemm.cpp,v 1.5 2009/09/25 04:00:39 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dgemm.f
-Rgemm performs one of the matrix-matrix operations
- C := alpha*op(A)*op(B) + beta*C,
-where op(X) is one of
- op(X) = X or op(X) = X',
-alpha and beta are scalars, and A, B and C are matrices, with op( A )
-an m by k matrix, op(B) a k by n matrix and C an m by n matrix.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rgemm(const char *transa, const char *transb, mpackint m, mpackint n,
- mpackint k, mpf_class alpha, mpf_class * A, mpackint lda, mpf_class * B,
- mpackint ldb, mpf_class beta, mpf_class * C, mpackint ldc)
-{
- mpackint nota, notb;
- mpackint nrowa, ncola;
- mpackint nrowb;
- mpackint info;
-
- mpf_class Zero = 0.0, One = 1.0;
- mpf_class temp;
-
- nota = Mlsame_gmp(transa, "N");
- notb = Mlsame_gmp(transb, "N");
-
- if (nota) {
- nrowa = m;
- ncola = k;
- } else {
- nrowa = k;
- ncola = m;
- }
- if (notb) {
- nrowb = k;
- } else {
- nrowb = n;
- }
-
- //Test the input parameters.
- info = 0;
- if (!nota && (!Mlsame_gmp(transa, "C")) && (!Mlsame_gmp(transa, "T")))
- info = 1;
- else if (!notb && (!Mlsame_gmp(transb, "C")) && (!Mlsame_gmp(transb, "T")))
- info = 2;
- else if (m < 0)
- info = 3;
- else if (n < 0)
- info = 4;
- else if (k < 0)
- info = 5;
- else if (lda < max((mpackint) 1, nrowa))
- info = 8;
- else if (ldb < max((mpackint) 1, nrowb))
- info = 10;
- else if (ldc < max((mpackint) 1, m))
- info = 13;
- if (info != 0) {
- Mxerbla_gmp("Rgemm ", info);
- return;
- }
-//Quick return if possible.
- if ((m == 0) || (n == 0) || (((alpha == Zero) || (k == 0))
- && (beta == One)))
- return;
-
-//And when alpha == 0.0
- if (alpha == Zero) {
- if (beta == Zero) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i < m; i++) {
- C[i + j * ldc] = Zero;
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i < m; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- }
- return;
- }
-//Start the operations.
- if (notb) {
- if (nota) {
- //Form C := alpha*A*B + beta*C.
- for (mpackint j = 0; j < n; j++) {
- if (beta == Zero) {
- for (mpackint i = 0; i < m; i++) {
- C[i + j * ldc] = Zero;
- }
- } else if (beta != One) {
- for (mpackint i = 0; i < m; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- for (mpackint l = 0; l < k; l++) {
- if (B[l + j * ldb] != Zero) {
- temp = alpha * B[l + j * ldb];
- for (mpackint i = 0; i < m; i++) {
- C[i + j * ldc] =
- C[i + j * ldc] + temp * A[i + l * lda];
- }
- }
- }
- }
- } else {
-//Form C := alpha*A'*B + beta*C.
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i < m; i++) {
- temp = Zero;
- for (mpackint l = 0; l < k; l++) {
- temp = temp + A[l + i * lda] * B[l + j * ldb];
- }
- if (beta == Zero)
- C[i + j * ldc] = alpha * temp;
- else
- C[i + j * ldc] = alpha * temp + beta * C[i + j * ldc];
- }
- }
- }
- } else {
- if (nota) {
-//Form C := alpha*A*B' + beta*C.
- for (mpackint j = 0; j < n; j++) {
- if (beta == Zero) {
- for (mpackint i = 0; i < m; i++) {
- C[i + j * ldc] = Zero;
- }
- } else if (beta != One) {
- for (mpackint i = 0; i < m; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- for (mpackint l = 0; l < k; l++) {
- if (B[j + l * ldb] != Zero) {
- temp = alpha * B[j + l * ldb];
- for (mpackint i = 0; i < m; i++) {
- C[i + j * ldc] =
- C[i + j * ldc] + temp * A[i + l * lda];
- }
- }
- }
- }
- } else {
-//Form C := alpha*A'*B' + beta*C.
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i < m; i++) {
- temp = Zero;
- for (mpackint l = 0; l < k; l++) {
- temp = temp + A[l + i * lda] * B[j + l * ldb];
- }
- if (beta == Zero)
- C[i + j * ldc] = alpha * temp;
- else
- C[i + j * ldc] = alpha * temp + beta * C[i + j * ldc];
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rgemv.cpp b/mpack/Rgemv.cpp
deleted file mode 100644
index 9943b3e..0000000
--- a/mpack/Rgemv.cpp
+++ /dev/null
@@ -1,177 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rgemv.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dgemv.f
-Rgemv 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 matrix.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rgemv(const char *trans, mpackint m, mpackint n, mpf_class alpha,
- mpf_class * A, mpackint lda, mpf_class * x, mpackint incx, mpf_class beta,
- mpf_class * y, mpackint incy)
-{
- mpackint lenx, leny, ix, jx, kx, iy, jy, ky;
-
- mpackint info = 0;
-
- mpf_class Zero = 0.0, One = 1.0;
-
- mpf_class temp;
-
- //Test the input parameters.
- if (!Mlsame_gmp(trans, "N") && !Mlsame_gmp(trans, "T") && !Mlsame_gmp(trans, "C"))
- info = 1;
- else if (m < 0)
- info = 2;
- else if (n < 0)
- info = 3;
- else if (lda < max((mpackint) 1, m))
- info = 6;
- else if (incx == 0)
- info = 8;
- else if (incy == 0)
- info = 11;
- if (info != 0) {
- Mxerbla_gmp("Rgemv ", info);
- return;
- }
- //Quick return if possible.
- if ((m == 0) || (n == 0) || ((alpha == Zero) && (beta == One)))
- return;
-
- //Set lenx and leny, the lengths of the vectors x and y, and set
- //up the start points in x and y.
- if (Mlsame_gmp(trans, "N")) {
- lenx = n;
- leny = m;
- } else {
- lenx = m;
- leny = n;
- }
- if (incx > 0)
- kx = 0;
- else
- kx = (1 - lenx) * incx;
- if (incy > 0)
- ky = 0;
- else
- ky = (1 - leny) * incy;
-
- //start the operations. in this version the elements of a are
- //accessed sequentially with One pass through a.
- //first form y := beta*y.
- if (beta != One) {
- iy = ky;
- if (beta == Zero) {
- for (mpackint i = 0; i < leny; i++) {
- y[iy] = Zero;
- iy = iy + incy;
- }
- } else {
- for (mpackint i = 0; i < leny; i++) {
- y[iy] = beta * y[iy];
- iy = iy + incy;
- }
- }
- }
- if (alpha == Zero)
- return;
- if (Mlsame_gmp(trans, "N")) {
- //form y := alpha*A*x + y.
- jx = kx;
- for (mpackint j = 0; j < n; j++) {
- if (x[jx] != Zero) {
- temp = alpha * x[jx];
- iy = ky;
- for (mpackint i = 0; i < m; i++) {
- y[iy] = y[iy] + temp * A[i + j * lda];
- iy = iy + incy;
- }
- }
- jx = jx + incx;
- }
- } else {
- //Form y := alpha*A'*x + y.
- jy = ky;
- for (mpackint j = 0; j < n; j++) {
- temp = Zero;
- ix = kx;
- for (mpackint i = 0; i < m; i++) {
- temp = temp + A[i + j * lda] * x[ix];
- ix = ix + incx;
- }
- y[jy] = y[jy] + alpha * temp;
- jy = jy + incy;
- }
- }
- return;
-}
diff --git a/mpack/Rger.cpp b/mpack/Rger.cpp
deleted file mode 100644
index b2bc419..0000000
--- a/mpack/Rger.cpp
+++ /dev/null
@@ -1,130 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rger.cpp,v 1.5 2009/09/25 04:00:39 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dger.f
-Rger 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.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rger(mpackint m, mpackint n, mpf_class alpha, mpf_class * x, mpackint incx,
- mpf_class * y, mpackint incy, mpf_class * A, mpackint lda)
-{
- mpackint ix, kx, jy;
- mpf_class Zero = 0.0, One = 1.0;
- mpf_class temp;
-
-//Test the input parameters.
- mpackint 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 < max((mpackint) 1, m))
- info = 9;
- if (info != 0) {
- Mxerbla_gmp("Rger ", info);
- return;
- }
- //quick return if possible.
- if ((m == 0) || (n == 0) || (alpha == Zero))
- return;
-
- //start the operations. in this version the elements of a are
- //accessed sequentially with one pass through A.
- if (incy > 0)
- jy = 0;
- else
- jy = (1 - n) * incy;
-
- if (incx > 0)
- kx = 0;
- else
- kx = (1 - m) * incx;
-
- for (mpackint j = 0; j < n; j++) {
- if (y[jy] != Zero) {
- temp = alpha * y[jy];
- ix = kx;
- for (mpackint i = 0; i < m; i++) {
- A[i + j * lda] = A[i + j * lda] + x[ix] * temp;
- ix = ix + incx;
- }
- }
- jy = jy + incy;
- }
- return;
-}
diff --git a/mpack/Rlae2.cpp b/mpack/Rlae2.cpp
deleted file mode 100644
index eb26ad9..0000000
--- a/mpack/Rlae2.cpp
+++ /dev/null
@@ -1,110 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlae2.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rlae2(mpf_class a, mpf_class b, mpf_class c, mpf_class * rt1, mpf_class * rt2)
-{
- mpf_class sm, df, adf, tb, ab;
- mpf_class acmx, acmn, rt;
- mpf_class One = 1.0, Two = 2.0, Half = .5;
-
- sm = a + c;
- df = a - c;
- adf = abs(df);
- tb = b + b;
- ab = abs(tb);
-
- if (abs(a) > abs(c)) {
- acmx = a;
- acmn = c;
- } else {
- acmx = c;
- acmn = a;
- }
- if (adf > ab) {
- rt = adf * sqrt(One + (ab / adf) * (ab / adf));
- } else if (adf < ab) {
- rt = ab * sqrt(One + (adf / ab) * (adf / ab));
- } else {
- rt = ab * sqrt(Two);
- }
-
- if (sm < 0.0) {
- *rt1 = Half * (sm - rt);
- *rt2 = (acmx / (*rt1)) * acmn - (b / (*rt1)) * b;
- } else if (sm > 0.0) {
- *rt1 = Half * (sm + rt);
- *rt2 = (acmx / (*rt1)) * acmn - (b / (*rt1)) * b;
- } else {
- *rt1 = Half * rt;
- *rt2 = -Half * rt;
- }
- return;
-}
diff --git a/mpack/Rlaev2.cpp b/mpack/Rlaev2.cpp
deleted file mode 100644
index 2cc92fe..0000000
--- a/mpack/Rlaev2.cpp
+++ /dev/null
@@ -1,159 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlaev2.cpp,v 1.4 2009/09/26 02:21:32 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-// http://www.netlib.org/lapack/double/dlaev2.f
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <stdio.h> //for printf. shall be removed
-
-void
-Rlaev2(mpf_class a, mpf_class b, mpf_class c, mpf_class * rt1, mpf_class * rt2,
- mpf_class * cs1, mpf_class * sn1)
-{
- mpf_class ab, acmn, acmx, acs, adf;
- mpf_class cs, ct, df, rt, sm, tb, tn;
- mpf_class zero, one, two, half;
- mpackint sgn1, sgn2;
-
- zero = 0.0;
- one = 1.0;
- two = 2.0;
- half = 0.5;
-
- sm = a + c;
- df = a - c;
- adf = abs(df);
- tb = b + b;
- ab = abs(tb);
-
- if (abs(a) > abs(c)) {
- acmx = a;
- acmn = c;
- } else {
- acmx = c;
- acmn = a;
- }
- if (adf > ab) {
- rt = adf * sqrt(one + (ab / adf) * (ab / adf));
- } else if (adf < ab) {
- rt = ab * sqrt(one + (adf / ab) * (adf / ab));
- } else {
-//Includes case AB=ADF=0
- rt = ab * sqrt(two);
- }
- if (sm < zero) {
- *rt1 = half * (sm - rt);
- sgn1 = -1;
-//Order of execution important.
-//To get fully accurate smaller eigenvalue,
-//next line needs to be executed in higher precision.
- *rt2 = (acmx / (*rt1)) * acmn - (b / (*rt1)) * b;
- } else if (sm > zero) {
- *rt1 = half * (sm + rt);
- sgn1 = 1;
-//Order of execution important.
-//To get fully accurate smaller eigenvalue,
-//next line needs to be executed in higher precision.
- *rt2 = (acmx / (*rt1)) * acmn - (b / (*rt1)) * b;
- } else {
-//Includes case RT1 = RT2 = 0
- *rt1 = half * rt;
- *rt2 = -1.0 * half * rt;
- sgn1 = 1;
- }
-//Compute the eigenvector
- if (df >= zero) {
- cs = df + rt;
- sgn2 = 1;
- } else {
- cs = df - rt;
- sgn2 = -1;
- }
- acs = abs(cs);
- if (acs > ab) {
- ct = -tb / cs;
- *sn1 = one / sqrt(one + ct * ct);
- *cs1 = ct * (*sn1);
- } else {
- if (ab == zero) {
- *cs1 = one;
- *sn1 = zero;
- } else {
- printf("#Rlaev2 Checkpoint 13 Not checked\n");
- exit(1);
- tn = -cs / tb;
- *cs1 = one / sqrt(one + tn * tn);
- *sn1 = tn * (*cs1);
- }
- }
- if (sgn1 == sgn2) {
- tn = *cs1;
- *cs1 = -(*sn1);
- *sn1 = tn;
- }
- return;
-}
diff --git a/mpack/Rlamch.cpp b/mpack/Rlamch.cpp
deleted file mode 100644
index 36b334e..0000000
--- a/mpack/Rlamch.cpp
+++ /dev/null
@@ -1,235 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlamch_gmp.cpp,v 1.7 2009/09/18 23:01:08 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-//"E" denots we always calculate relative machine precision (e).
-//where 1+e > 1, minimum of e.
-mpf_class RlamchE_gmp(void)
-{
- static mpf_class eps;
- static int called = 0;
- if (called)
- return eps;
- mpf_class one;
- unsigned long exp2;
- one = 1.0;
- exp2 = mpf_get_prec(one.get_mpf_t());
- mpf_div_2exp(eps.get_mpf_t(), one.get_mpf_t(), exp2);
- called = 1;
- return eps;
-}
-
-//"S" denots we always calculate `safe minimum, such that 1/sfmin does not overflow'.
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchS_gmp(void)
-{
- mpf_class sfmin;
- mpf_class one = 1.0;
- unsigned long exp2;
-
- exp2 = (1UL << (mp_bits_per_limb-8)) - 1; //6 seems to be the smallest on amd64 but for safty
- mpf_div_2exp(sfmin.get_mpf_t(), one.get_mpf_t(), exp2);
- return sfmin;
-
-/* following code fragment is to test safe minimum
- mpf_class largenum;
- for(int p = 60; p>=0; p--) {
- for (int a=16; a<= 5120; a=a+128) {
- sfmin = 0.0;
- mpf_set_default_prec(a);
- exp2 = (1UL << (mp_bits_per_limb-p)) - 1;
- mpf_div_2exp(sfmin.get_mpf_t(), one.get_mpf_t(), exp2);
- largenum = 1.0 / sfmin;
- gmp_printf("%d, a:%5d, p:%5d sfmin: %16.20Fe largenum: %16.20Fe\n", mp_bits_per_limb, a, p, sfmin.get_mpf_t(), largenum.get_mpf_t());
- if (sfmin < 1.0 ) { printf("sfmin yes\n"); }
- if (largenum > 1.0 ) { printf("largenum yes\n"); }
- }
- }
-*/
-
-}
-//"B" base = base of the machine
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchB_gmp(void)
-{
- mpf_class two;
- two = 2.0;
- return two;
-}
-
-//"P" prec = eps*base
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchP_gmp(void)
-{
- mpf_class base, eps, prec;
-
- base = RlamchB_gmp();
- eps = RlamchE_gmp();
- prec = eps * base;
- return prec;
-}
-
-//"N" t = number of digits in mantissa
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchN_gmp(void)
-{
- unsigned long int tmp;
- mpf_class mtmp;
- mpf_class mtmp2;
- tmp = mpf_get_prec(mtmp.get_mpf_t());
- mtmp2 = tmp;
- return mtmp2;
-
-/* following is fragment of code to test digits in mantissa
- for (int a=8; a<= 5120; a=a+128) {
- mpf_set_default_prec(a);
- mpf_class mmtmp;
- tmp = mpf_get_prec(mmtmp.get_mpf_t());
- printf("number of digits in mantissa %d\n", (int)tmp );
- }
-*/
-
-}
-
-//"R" rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchR_gmp(void)
-{
-//always rounding in addition on GMP.
- mpf_class mtmp;
-
- mtmp = 1.0;
- return mtmp;
-}
-
-//"M"
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchM_gmp(void)
-{
- unsigned long exp2;
- mpf_class tmp;
- mpf_class uflowmin, one=1.0;
- exp2 = (1UL << (mp_bits_per_limb-8)) - 1; //6 seems to be the smallest on amd64 but for safty
- tmp = exp2;
- return -tmp;
-
-/*
- following code fragment is to test minimum
- exponent before (gradual) underflow...but we just got Bus error
- mpf_class mtmp1, mtmp2;
- for(int p = 11; p>=0; p--) {
- for (int a=51200; a<= 102400; a=a+128) {
- mpf_set_default_prec(a);
- printf("p %d a %d \n", p, a);
- uflowmin=0.0;
- exp2 = (1UL << (mp_bits_per_limb-p)) - 1;
- mpf_div_2exp(uflowmin.get_mpf_t(), one.get_mpf_t(), exp2);
- mtmp1 = uflowmin/2.0;
- gmp_printf("p %d, uflowmin: %16.20Fe uflowmin/2 %16.20Fe\n", p, uflowmin.get_mpf_t(), mtmp1.get_mpf_t());
- mtmp2 = mtmp1 * 2.0;
- gmp_printf("mtmp2: %16.20Fe %lu\n", mtmp2.get_mpf_t(),exp2);
- if (uflowmin != mtmp2 ) { printf("underflow\n"); exit(1); }
- }
- }
-*/
-}
-
-//"U"
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchU_gmp(void)
-{
- mpf_class underflowmin;
- mpf_class one = 1.0;
- unsigned long exp2;
- exp2 = (1UL << (mp_bits_per_limb-8)) - 1; //6 seems to be the smallest on amd64 but for safty
- mpf_div_2exp(underflowmin.get_mpf_t(), one.get_mpf_t(), exp2);
- return underflowmin;
-}
-
-//"L"
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchL_gmp(void)
-{
- mpf_class maxexp;
- unsigned long exp2;
- exp2 = (1UL << (mp_bits_per_limb-8)) - 1; //6 seems to be the smallest on amd64 but for safty
- maxexp = exp2;
- return maxexp;
-}
-
-//"O"
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchO_gmp(void)
-{
- mpf_class overflowmax;
- mpf_class one = 1.0;
- unsigned long exp2;
-
- exp2 = (1UL << (mp_bits_per_limb-8)) - 1; //6 seems to be the smallest on amd64 but for safty
- mpf_mul_2exp(overflowmax.get_mpf_t(), one.get_mpf_t(), exp2);
-
- return overflowmax;
-}
-
-//"Z" :dummy
-//cf.http://www.netlib.org/blas/dlamch.f
-mpf_class RlamchZ_gmp(void)
-{
- mpf_class mtemp = 0.0;
- return mtemp;
-}
-
-mpf_class Rlamch_gmp(const char *cmach)
-{
- if (Mlsame_gmp(cmach, "E"))
- return RlamchE_gmp();
- if (Mlsame_gmp(cmach, "S"))
- return RlamchS_gmp();
- if (Mlsame_gmp(cmach, "B"))
- return RlamchB_gmp();
- if (Mlsame_gmp(cmach, "P"))
- return RlamchP_gmp();
- if (Mlsame_gmp(cmach, "N"))
- return RlamchN_gmp();
- if (Mlsame_gmp(cmach, "R"))
- return RlamchR_gmp();
- if (Mlsame_gmp(cmach, "M"))
- return RlamchM_gmp();
- if (Mlsame_gmp(cmach, "U"))
- return RlamchU_gmp();
- if (Mlsame_gmp(cmach, "L"))
- return RlamchL_gmp();
- if (Mlsame_gmp(cmach, "O"))
- return RlamchO_gmp();
-
- Mxerbla_gmp("Rlamch", 1);
- return RlamchZ_gmp();
-}
diff --git a/mpack/Rlanst.cpp b/mpack/Rlanst.cpp
deleted file mode 100644
index 53b3e64..0000000
--- a/mpack/Rlanst.cpp
+++ /dev/null
@@ -1,121 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlanst.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-#ifndef max
-#define max(a,b) (((a)>(b))?(a):(b))
-#endif
-#ifndef min
-#define min(a,b) (((a)<(b))?(a):(b))
-#endif
-
-mpf_class
-Rlanst(const char *norm, mpackint n, mpf_class * d, mpf_class * e)
-{
- mpackint i;
- mpf_class anorm, scale, sum;
- mpf_class Zero = 0.0;
- mpf_class One = 1.0;
- mpf_class mtmp1, mtmp2;
-
- if (n <= 0) {
- anorm = Zero;
- } else if (Mlsame_gmp(norm, "M")) {
-//Find max(abs(A(i,j))).
- anorm = abs(d[n - 1]);
- for (i = 0; i < n - 1; i++) {
- mtmp1 = abs(d[i]);
- mtmp2 = abs(e[i]);
- anorm = max(anorm, mtmp1);
- anorm = max(anorm, mtmp2);
-// anorm = max(anorm, abs(d[i]));
-// anorm = max(anorm, abs(e[i]));
- }
- } else if (Mlsame_gmp(norm, "O") || Mlsame_gmp(norm, "1") || Mlsame_gmp(norm, "I")) {
- if (n == 1) {
- anorm = abs(d[0]);
- } else {
- anorm = max(abs(d[0]) + abs(e[0]), abs(e[n - 2]) + abs(d[n - 1]));
- for (i = 1; i < n - 1; i++) {
- anorm = max(anorm, abs(d[i]) + abs(e[i]) + abs(e[i - 1]));
- }
- }
- } else if (Mlsame_gmp(norm, "F") || Mlsame_gmp(norm, "E")) {
-//Find normF(A).
- scale = Zero;
- sum = One;
- if (n > 1) {
- Rlassq(n - 1, e, 1, &scale, &sum);
- sum *= 2.0;
- }
- Rlassq(n, d, 1, &scale, &sum);
- anorm = scale * sqrt(sum);
- }
- return anorm;
-}
diff --git a/mpack/Rlansy.cpp b/mpack/Rlansy.cpp
deleted file mode 100644
index 10d33f7..0000000
--- a/mpack/Rlansy.cpp
+++ /dev/null
@@ -1,149 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlansy.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-mpf_class
-Rlansy(const char *norm, const char *uplo, mpackint n, mpf_class * A, mpackint lda,
- mpf_class * work)
-{
- mpf_class One = 1.0, Zero = 0.0;
- mpackint i, j;
- mpf_class absa, scale, sum, value;
- mpf_class mtmp;
-
- if (n == 0) {
- value = Zero;
- return value;
- }
- if (Mlsame_gmp(norm, "M")) {
-//Find max(abs(A(i,j))).
- value = Zero;
- if (Mlsame_gmp(uplo, "U")) {
- for (j = 0; j < n; j++) {
- for (i = 0; i <= j; i++) {
- mtmp = abs(A[i + j * lda]);
- value = max(value, mtmp);
- }
- }
- } else {
- for (j = 0; j < n; j++) {
- for (i = j; i < n; i++) {
- mtmp = abs(A[i + j * lda]);
- value = max(value, mtmp);
- }
- }
- }
- } else if (Mlsame_gmp(norm, "I") || Mlsame_gmp(norm, "O") || Mlsame_gmp(norm, "1")) {
-// Find normI(A) ( = norm1(A), since A is symmetric).
- value = Zero;
- if (Mlsame_gmp(uplo, "U")) {
- for (j = 0; j < n; j++) {
- sum = Zero;
- for (i = 0; i < j; i++) {
- absa = abs(A[i + j * lda]);
- sum += absa;
- work[i] += absa;
- }
- work[j] = sum + abs(A[j + j * lda]);
- }
- for (i = 0; i < n; i++) {
- value = max(value, work[i]);
- }
- } else {
- for (i = 0; i < n; i++) {
- work[i] = Zero;
- }
- for (j = 0; j < n; j++) {
- sum = work[j] + abs(A[j + j * lda]);
- for (i = j + 1; i < n; i++) {
- absa = abs(A[i + j * lda]);
- sum += absa;
- work[i] += absa;
- }
- value = max(value, sum);
- }
- }
- } else if (Mlsame_gmp(norm, "F") || Mlsame_gmp(norm, "E")) {
-//Find normF(A).
- scale = Zero;
- sum = One;
- if (Mlsame_gmp(uplo, "U")) {
- for (j = 1; j < n; j++) {
- Rlassq(j, &A[j * lda], 1, &scale, &sum);
- }
- } else {
- for (j = 0; j < n - 1; j++) {
- Rlassq(n - j - 1, &A[(j + 1) + j * lda], 1, &scale, &sum);
- }
- }
- sum *= 2.0;
- Rlassq(n, A, lda + 1, &scale, &sum);
- value = scale * sqrt(sum);
- }
- return value;
-}
diff --git a/mpack/Rlapy2.cpp b/mpack/Rlapy2.cpp
deleted file mode 100644
index dbbfa63..0000000
--- a/mpack/Rlapy2.cpp
+++ /dev/null
@@ -1,90 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlapy2.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-mpf_class
-Rlapy2(mpf_class x, mpf_class y)
-{
- mpf_class Zero = 0.0;
- mpf_class One = 1.0;
- mpf_class w, z;
-
- mpf_class xabs, yabs;
-
- xabs = abs(x);
- yabs = abs(y);
- w = max(xabs, yabs);
- z = min(xabs, yabs);
- if (z == Zero) {
- return w;
- } else {
- w = w * sqrt(One + (z / w) * (z / w));
- return w;
- }
-//not reached
-}
diff --git a/mpack/Rlarf.cpp b/mpack/Rlarf.cpp
deleted file mode 100644
index e6a5fdd..0000000
--- a/mpack/Rlarf.cpp
+++ /dev/null
@@ -1,94 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlarf.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rlarf(const char *side, mpackint m, mpackint n, mpf_class * v, mpackint incv, mpf_class tau,
- mpf_class * C, mpackint ldc, mpf_class * work)
-{
- mpf_class One = 1.0, Zero = 0.0;
-
- if (Mlsame_gmp(side, "L")) {
-//Form H * C
- if (tau != Zero) {
-//w := C' * v
- Rgemv("Transpose", m, n, One, C, ldc, v, incv, Zero, work, 1);
-//C := C - v * w'
- Rger(m, n, -tau, v, incv, work, 1, C, ldc);
- }
- } else {
-//Form C * H
- if (tau != Zero) {
-//w := C * v
- Rgemv("No transpose", m, n, One, C, ldc, v, incv, Zero, work, 1);
-//C := C - w * v'
- Rger(m, n, -tau, work, 1, v, incv, C, ldc);
- }
- }
- return;
-}
diff --git a/mpack/Rlarfb.cpp b/mpack/Rlarfb.cpp
deleted file mode 100644
index 337043d..0000000
--- a/mpack/Rlarfb.cpp
+++ /dev/null
@@ -1,393 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlarfb.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
- * Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
- *
- * $COPYRIGHT$
- *
- * Additional copyrights may follow
- *
- * $HEADER$
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * - Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
- *
- * - Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer listed in this
- * license in the documentation and/or other materials provided with the
- * distribution.
- *
- * - Neither the name of the copyright holders nor the names of its contributors
- * may be used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
- * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
- * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
- * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- * POSSIBILITY OF SUCH DAMAGE.
- */
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rlarfb(const char *side, const char *trans, const char *direct,
- const char *storev, mpackint m, mpackint n, mpackint k, mpf_class * V, mpackint ldv,
- mpf_class * T, mpackint ldt, mpf_class * C, mpackint ldc, mpf_class * work,
- mpackint ldwork)
-{
- mpackint i, j;
- mpf_class One = 1.0;
- mpf_class mOne = -1.0;
- char transt;
-
- //Quick return if possible
- if (m <= 0 || n <= 0)
- return;
-
- if (Mlsame_gmp(trans, "N")) {
- transt = 'T';
- } else {
- transt = 'N';
- }
-
- if (Mlsame_gmp(storev, "C")) {
- if (Mlsame_gmp(direct, "F")) {
-
-//Let V = (V1) (first K rows)
-// (V2)
-// where V1 is unit lower triangular.
- if (Mlsame_gmp(side, "L")) {
-
-//Form H * C or H ' * C where C = ( C1 )
-// ( C2 )
-// W: = C ' * V = (C1' * V1 + C2 '*V2) (stored in WORK)
-// W: = C1 '
- for (j = 0; j < k; j++) {
- Rcopy(n, &C[j], ldc, &work[j * ldwork], 1);
- }
-//W: = W * V1
- Rtrmm("Right", "Lower", "No transpose", "Unit", n, k, One,
- &V[0], ldv, &work[0], ldwork);
- if (m > k) {
-//W: = W + C2 '*V2
- Rgemm("Transpose", "No transpose", n, k, m - k, One,
- &C[k], ldc, &V[k], ldv, One, &work[0], ldwork);
- }
-//W: = W * T ' or W * T
- Rtrmm("Right", "Upper", &transt, "Non-unit", n, k, One, &T[0],
- ldt, &work[0], ldwork);
-//C: = C - V * W '
- if (m > k) {
-//C2: = C2 - V2 * W '
- Rgemm("No transpose", "Transpose", m - k, n, k, mOne,
- &V[k], ldv, &work[0], ldwork, One, &C[k], ldc);
- }
-//W: = W * V1 '
- Rtrmm("Right", "Lower", "Transpose", "Unit", n, k, One, &V[0],
- ldv, &work[0], ldwork);
-
-//C1: = C1 - W '
- for (j = 0; j < k; j++) {
- for (i = 0; i < n; i++) {
- C[j + i * ldc] -= work[i + j * ldwork];
- }
- }
- } else if (Mlsame_gmp(side, "R")) {
-//Form C * H or C * H ' where C = ( C1 C2 )
-//W: = C * V = (C1 * V1 + C2 * V2) (stored in WORK)
-//W: = C1
- for (j = 0; j < k; j++) {
- Rcopy(m, &C[j * ldc], 1, &work[j * ldwork], 1);
- }
-//W: = W * V1
- Rtrmm("Right", "Lower", "No transpose", "Unit", m, k, One,
- &V[0], ldv, &work[0], ldwork);
- if (n > k) {
-//W: = W + C2 * V2
- Rgemm("No transpose", "No transpose", m, k, n - k, One,
- &C[k * ldc], ldc, &V[k], ldv, One, &work[0], ldwork);
- }
-//W: = W * T or W * T '
- Rtrmm("Right", "Upper", trans, "Non-unit", m, k, One, &T[0],
- ldt, &work[0], ldwork);
-//C: = C - W * V '
- if (n > k) {
-//C2: = C2 - W * V2'
- Rgemm("No transpose", "Transpose", m, n - k, k, mOne,
- &work[0], ldwork, &V[k], ldv, One, &C[k * ldc], ldc);
- }
-//W: = W * V1 '
- Rtrmm("Right", "Lower", "Transpose", "Unit", m, k, One, &V[0],
- ldv, &work[0], ldwork);
-//C1: = C1 - W
- for (j = 0; j < k; j++) {
- for (i = 0; i < m; i++) {
- C[i + j * ldc] -= work[i + j * ldwork];
- }
- }
- }
- } else {
-//Let V = (V1)
-// (V2) (last K rows)
-// where V2 is unit upper triangular.
- if (Mlsame_gmp(side, "L")) {
-//Form H * C or H ' * C where C = ( C1 )
-// ( C2 )
-//W: = C ' * V = (C1' * V1 + C2 '*V2) (stored in WORK)
-//W: = C2 '
- for (j = 0; j < k; j++) {
- Rcopy(n, &C[m - k + j], ldc, &work[j * ldwork], 1);
- }
-//W: = W * V2
- Rtrmm("Right", "Upper", "No transpose", "Unit", n, k, One,
- &V[m - k], ldv, &work[0], ldwork);
- if (m > k) {
-//W: = W + C1 '*V1
- Rgemm("Transpose", "No transpose", n, k, m - k, One,
- &C[0], ldc, &V[0], ldv, One, &work[0], ldwork);
- }
-//W: = W * T ' or W * T
- Rtrmm("Right", "Lower", &transt, "Non-unit", n, k, One, &T[0],
- ldt, &work[0], ldwork);
-//C: = C - V * W '
- if (m > k) {
-//C1:= C1 - V1 * W '
- Rgemm("No transpose", "Transpose", m - k, n, k, mOne,
- &V[0], ldv, &work[0], ldwork, One, &C[0], ldc);
- }
-//W: = W * V2 '
- Rtrmm("Right", "Upper", "Transpose", "Unit", n, k, One,
- &V[m - k], ldv, &work[0], ldwork);
-//C2:= C2 - W '
- for (j = 0; j < k; j++) {
- for (i = 0; i < n; i++) {
- C[m - k + j + i * ldc] -= work[i + j * ldwork];
- }
- }
- } else if (Mlsame_gmp(side, "R")) {
-//Form C * H or C * H ' where C = ( C1 C2 )
-// W: = C * V = (C1 * V1 + C2 * V2) (stored in WORK)
-// W: = C2
- for (j = 0; j < k; j++) {
- Rcopy(m, &C[(n - k + j) * ldc], 1, &work[j * ldwork], 1);
- }
-//W:= W * V2
- Rtrmm("Right", "Upper", "No transpose", "Unit", m, k, One,
- &V[n - k], ldv, &work[0], ldwork);
- if (n > k) {
-//W:= W + C1 * V1
- Rgemm("No transpose", "No transpose", m, k, n - k, One,
- &C[0], ldc, &V[0], ldv, One, &work[0], ldwork);
- }
-//W:= W * T or W * T
- Rtrmm("Right", "Lower", trans, "Non-unit", m, k, One, &T[0],
- ldt, &work[0], ldwork);
-//C:= C - W * V '
- if (n > k) {
-//C1:= C1 - W * V1 '
- Rgemm("No transpose", "Transpose", m, n - k, k, mOne,
- &work[0], ldwork, &V[0], ldv, One, &C[0], ldc);
- }
-//W: = W * V2 '
- Rtrmm("Right", "Upper", "Transpose", "Unit", m, k, One,
- &V[n - k], ldv, &work[0], ldwork);
-//C2:= C2 - W
- for (j = 0; j < k; j++) {
- for (i = 0; i < m; i++) {
- C[i + (n - k + j) * ldc] -= work[i + j * ldwork];
- }
- }
- }
- }
- } else if (Mlsame_gmp(storev, "R")) {
- if (Mlsame_gmp(direct, "F")) {
-//Let V = (V1 V2) (V1:first K columns)
-//where V1 is unit upper triangular.
-
- if (Mlsame_gmp(side, "L")) {
-//Form H * C or H ' * C where C = ( C1 )
-// ( C2 )
-// W:= C ' * V' = (C1 '*V1' + C2 '*V2') (stored in WORK)
-// W:= C1 '
- for (j = 0; j < k; j++) {
- Rcopy(n, &C[j], ldc, &work[j * ldwork], 1);
- }
-//W:= W * V1 '
- Rtrmm("Right", "Upper", "Transpose", "Unit", n, k, One, &V[0],
- ldv, &work[0], ldwork);
- if (m > k) {
-//W:= W + C2 '*V2'
- Rgemm("Transpose", "Transpose", n, k, m - k, One,
- &C[k], ldc, &V[k * ldv], ldv, One, &work[0], ldwork);
- }
-//W:= W * T ' or W * T
- Rtrmm("Right", "Upper", &transt, "Non-unit", n, k, One,
- &T[0], ldt, &work[0], ldwork);
-//C:= C - V ' * W'
- if (m > k) {
-//C2:= C2 - V2 ' * W'
- Rgemm("Transpose", "Transpose", m - k, n, k, mOne,
- &V[k * ldv], ldv, &work[0], ldwork, One, &C[k], ldc);
- }
-//W:= W * V1
- Rtrmm("Right", "Upper", "No transpose", "Unit", n, k, One,
- &V[0], ldv, &work[0], ldwork);
-//C1:= C1 - W '
- for (j = 0; j < k; j++) {
- for (i = 0; i < n; i++) {
- C[j + i * ldc] -= work[i + j * ldwork];
- }
- }
- } else if (Mlsame_gmp(side, "R")) {
-//Form C * H or C * H ' where C = ( C1 C2 )
-// W:= C * V ' = (C1*V1' + C2 * V2 ') (stored in WORK)
-// W:= C1
- for (j = 0; j < k; j++) {
- Rcopy(m, &C[j * ldc], 1, &work[j * ldwork], 1);
- }
-//W:= W * V1 '
- Rtrmm("Right", "Upper", "Transpose", "Unit", m, k, One, &V[0],
- ldv, &work[0], ldwork);
- if (n > k) {
-//W:= W + C2 * V2 '
- Rgemm("No transpose", "Transpose", m, k, n - k, One,
- &C[k * ldc], ldc, &V[k * ldv],
- ldv, One, &work[0], ldwork);
- }
-//W:= W * T or W * T '
- Rtrmm("Right", "Upper", trans, "Non-unit", m, k, One, &T[0],
- ldt, &work[0], ldwork);
-//C:= C - W * V
- if (n > k) {
-//C2:= C2 - W * V2
- Rgemm("No transpose", "No transpose", m, n - k, k, mOne,
- &work[0], ldwork, &V[k * ldv], ldv, One,
- &C[k * ldc], ldc);
- }
-//W:= W * V1
- Rtrmm("Right", "Upper", "No transpose", "Unit", m, k, One,
- &V[0], ldv, &work[0], ldwork);
-//C1:= C1 - W
- for (j = 0; j < k; j++) {
- for (i = 0; i < m; i++) {
- C[i + j * ldc] -= work[i + j * ldwork];
- }
- }
- }
- } else {
-//Let V = (V1 V2) (V2:last K columns)
-// where V2 is unit lower triangular.
- if (Mlsame_gmp(side, "L")) {
-//Form H * C or H ' * C where C = ( C1 )
-// ( C2 )
-//W:= C ' * V' = (C1 '*V1' + C2 '*V2') (stored in WORK)
-//W:= C2 '
- for (j = 0; j < k; j++) {
- Rcopy(n, &C[m - k + j], ldc, &work[j * ldwork], 1);
- }
-
-//W:= W * V2 '
- Rtrmm("Right", "Lower", "Transpose", "Unit", n, k, One,
- &V[(m - k) * ldv], ldv, &work[0], ldwork);
-
- if (m > k) {
-
-//W:= W + C1 '*V1'
- Rgemm("Transpose", "Transpose", n, k, m - k, One, &C[0],
- ldc, &V[0], ldv, One, &work[0], ldwork);
- }
-//W:= W * T ' or W * T
- Rtrmm("Right", "Lower", &transt, "Non-unit", n, k, One, &T[0],
- ldt, &work[0], ldwork);
-//C:= C - V ' * W'
- if (m > k) {
-
-//C1:= C1 - V1 ' * W'
- Rgemm("Transpose", "Transpose", m - k, n, k, mOne, &V[0],
- ldv, &work[0], ldwork, One, &C[0], ldc);
- }
-//W:= W * V2
- Rtrmm("Right", "Lower", "No transpose", "Unit", n, k, One,
- &V[(m - k) * ldv], ldv, &work[0], ldwork);
-//C2:= C2 - W '
- for (j = 0; j < k; j++) {
- for (i = 0; i < n; i++) {
- C[m - k + j + i * ldc] -= work[i + j * ldwork];
- }
- }
- } else if (Mlsame_gmp(side, "R")) {
-//Form C * H or C * H ' where C = ( C1 C2 )
-// W:= C * V ' = (C1*V1' + C2 * V2 ') (stored in WORK)
-// W:= C2
- for (j = 0; j < k; j++) {
- Rcopy(m, &C[(n - k + j) * ldc], 1, &work[j * ldwork], 1);
- }
-//W: = W * V2 '
- Rtrmm("Right", "Lower", "Transpose", "Unit", m, k, One,
- &V[(n - k) * ldv], ldv, &work[0], ldwork);
- if (n > k) {
-//W:= W + C1 * V1 '
- Rgemm("No transpose", "Transpose", m, k, n - k, One, &C[0],
- ldc, &V[0], ldv, One, &work[0], ldwork);
- }
-//W:= W * T or W * T '
- Rtrmm("Right", "Lower", trans, "Non-unit", m, k, One, &T[0],
- ldt, &work[0], ldwork);
-//C:= C - W * V
- if (n > k) {
-//C1:= C1 - W * V1
- Rgemm("No transpose", "No transpose", m, n - k, k, mOne,
- &work[0], ldwork, &V[0], ldv, One, &C[0], ldc);
- }
-//W:=W * V2
- Rtrmm("Right", "Lower", "No transpose", "Unit", m, k, One,
- &V[(n - k) * ldv], ldv, &work[0], ldwork);
-//C1: = C1 - W
- for (j = 0; j < k; j++) {
- for (i = 0; i < m; i++) {
- C[i + (n - k + j) * ldc] -= work[i + j * ldwork];
- }
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rlarfg.cpp b/mpack/Rlarfg.cpp
deleted file mode 100644
index cd35142..0000000
--- a/mpack/Rlarfg.cpp
+++ /dev/null
@@ -1,121 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlarfg.cpp,v 1.4 2009/09/26 02:21:32 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <stdio.h> //for debugging
-void
-Rlarfg(mpackint N, mpf_class * alpha, mpf_class * x, mpackint incx, mpf_class * tau)
-{
- mpf_class xnorm;
- mpf_class Zero = 0.0, One = 1.0;
- mpf_class beta;
- mpf_class safmin;
- mpf_class rsafmn;
- mpackint knt;
-
- if (N <= 1) {
- *tau = 0.0;
- return;
- }
- xnorm = Rnrm2(N - 1, x, incx);
-//H = I
- if (xnorm == 0.0) {
- *tau = 0.0;
- } else {
- beta = -1.0 * Msign(Rlapy2(*alpha, xnorm), *alpha);
- safmin = Rlamch_gmp("S") / Rlamch_gmp("E");
-
-//XNORM, BETA may be inaccurate; scale X and recompute them
- if (abs(beta) < safmin) {
- fprintf(stderr, "# Rlarfg: 1: XXX not very well tested\n");
- rsafmn = One / safmin;
- knt = 0;
- while (abs(beta) < safmin) {
- knt++;
- Rscal(N - 1, rsafmn, x, incx);
- beta = beta * rsafmn;
- *alpha = *alpha * rsafmn;
- }
-
-//New BETA is at most 1, at least SAFMIN
- xnorm = Rnrm2(N - 1, x, incx);
- beta = -1.0 * Msign(Rlapy2(*alpha, xnorm), *alpha);
- *tau = (beta - *alpha) / beta;
- Rscal(N - 1, One / (*alpha - beta), x, incx);
-
-//If ALPHA is subnormal, it may lose relative accuracy
- *alpha = beta;
- for (mpackint j = 0; j < knt; j++) {
- *alpha = *alpha * safmin;
- }
- } else {
- *tau = (beta - *alpha) / beta;
- Rscal(N - 1, One / (*alpha - beta), x, incx);
- *alpha = beta;
- }
- }
-}
diff --git a/mpack/Rlarft.cpp b/mpack/Rlarft.cpp
deleted file mode 100644
index 84f19f0..0000000
--- a/mpack/Rlarft.cpp
+++ /dev/null
@@ -1,149 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlarft.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rlarft(const char *direct, const char *storev, mpackint n, mpackint k, mpf_class * v,
- mpackint ldv, mpf_class * tau, mpf_class * t, mpackint ldt)
-{
- mpf_class Zero = 0.0, One = 1.0;
- mpf_class vii;
- mpackint i, j;
-
- //Quick return if possible
- if (n == 0)
- return;
-
- if (Mlsame_gmp(direct, "F")) {
- for (i = 1; i <= k; i++) {
- if (tau[i - 1] == Zero) {
- //H(i) = I
- for (j = 1; j <= i; j++) {
- t[(j - 1) + (i - 1) * ldt] = Zero;
- }
- } else {
- //general case
- vii = v[(i - 1) + (i - 1) * ldv];
- v[(i - 1) + (i - 1) * ldv] = One;
- if (Mlsame_gmp(storev, "C")) {
- // T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
- Rgemv("Transpose", n - i + 1, i - 1, -tau[i - 1],
- &v[(i - 1) + 0 * ldv], ldv,
- &v[(i - 1) + (i - 1) * ldv], 1, Zero,
- &t[0 + (i - 1) * ldt], 1);
- } else {
- //T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
- Rgemv("No transpose", i - 1, n - i + 1, -tau[i - 1],
- &v[0 + (i - 1) * ldv], ldv,
- &v[(i - 1) + (i - 1) * ldv], ldv, Zero,
- &t[0 + (i - 1) * ldt], 1);
- }
- v[(i - 1) + (i - 1) * ldv] = vii;
- //T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
- Rtrmv("Upper", "No transpose", "Non-unit", i - 1, t, ldt,
- &t[0 + (i - 1) * ldt], 1);
- t[(i - 1) + (i - 1) * ldt] = tau[i - 1];
- }
- }
- } else {
- for (i = k; i >= 1; i--) {
- if (tau[i - 1] == Zero) {
- //H(i) = I
- for (j = i; j < k; j++) {
- t[(j - 1) + (i - 1) * ldt] = Zero;
- }
- } else {
- //general case
- if (i < k) {
- if (Mlsame_gmp(storev, "C")) {
- vii = v[(n - k + i - 1) + (i - 1) * ldv];
- v[(n - k + i - 1) + (i - 1) * ldv] = One;
- //T(i+1:k,i) := - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
- Rgemv("Transpose", n - k + i, k - i, -tau[i - 1],
- &v[0 + i * ldv], ldv, &v[0 + (i - 1) * ldv], 1,
- Zero, &t[i + (i - 1) * ldt], 1);
- v[(n - k + i - 1) + (i - 1) * ldv] = vii;
- } else {
- vii = v[(i - 1) + (n - k + i - 1) * ldv];
- v[(i - 1) + (n - k + i - 1) * ldv] = One;
- //T(i+1:k,i) := - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
- Rgemv("No transpose", k - i, n - k + i, -tau[i - 1],
- &v[i + 0 * ldv], ldv, &v[(i - 1) + 0 * ldv], ldv,
- Zero, &t[i + (i - 1) * ldt], 1);
- v[(i - 1) + (n - k + i - 1) * ldv] = vii;
- }
- //T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
- Rtrmv("Lower", "No transpose", "Non-unit", k - i,
- &t[i + i * ldt], ldt, &t[i + (i - 1) * ldt], 1);
- }
- t[(i - 1) + (i - 1) * ldt] = tau[i - 1];
- }
- }
- }
- return;
-}
diff --git a/mpack/Rlartg.cpp b/mpack/Rlartg.cpp
deleted file mode 100644
index d5459e8..0000000
--- a/mpack/Rlartg.cpp
+++ /dev/null
@@ -1,155 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlartg.cpp,v 1.4 2009/09/26 02:21:32 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <stdio.h> //for printf
-
-void
-Rlartg(mpf_class f, mpf_class g, mpf_class * cs, mpf_class * sn, mpf_class * r)
-{
- mpf_class Zero;
- mpf_class One;
- mpf_class Two;
- mpf_class f1, g1;
- mpackint i, count;
-
- Zero = 0.0;
- One = 1.0;
- Two = 2.0;
-
- mpf_class safmin;
- mpf_class safmn2;
- mpf_class safmx2, eps, scale;
-
- safmin = Rlamch_gmp("S");
- eps = Rlamch_gmp("E");
-// SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / LOG( DLAMCH( 'B' ) ) / TWO );
-// ~ 2^(ln(safmin/eps) / 2ln2 ) (dlamchB=2) = sqrt(safmin/eps).
- safmn2 = sqrt(safmin / eps);
- safmx2 = 1.0 / safmn2;
-
- if (g == Zero) {
- *cs = One;
- *sn = Zero;
- *r = f;
- } else if (f == Zero) {
- *cs = Zero;
- *sn = One;
- *r = g;
- } else {
- f1 = f;
- g1 = g;
- scale = max(abs(f1), abs(g1));
- count = 0;
- if (scale >= safmx2) {
- printf("#XXX Rlartg :1: not yet implemented.\n");
- while (1) {
- count++;
- f1 = f1 * safmn2;
- g1 = g1 * safmn2;
- scale = max(abs(f1), abs(g1));
- if (scale >= safmx2)
- continue;
-
- *r = sqrt(f1 * f1 + g1 * g1);
- *cs = f1 / (*r);
- *sn = g1 / (*r);
- for (i = 0; i < count; i++) {
- *r = (*r) * safmx2;
- }
- break;
- }
- } else if (scale <= safmn2) {
- printf("#XXX Rlartg :3:very well tested. \n");
- while (1) {
- count++;
- f1 = f1 * safmx2;
- g1 = g1 * safmn2;
- scale = max(abs(f1), abs(g1));
- if (scale >= safmx2)
- continue;
- *r = sqrt(f1 * f1 + g1 * g1);
- *cs = f1 / (*r);
- *sn = g1 / (*r);
- for (i = 0; i < count; i++) {
- *r = (*r) * safmx2;
- }
- break;
- }
- } else {
- *r = sqrt(f1 * f1 + g1 * g1);
- *cs = f1 / (*r);
- *sn = g1 / (*r);
- }
- if (abs(f) > abs(g) && (*cs) < Zero) {
- *cs = -(*cs);
- *sn = -(*sn);
- *r = -(*r);
- }
- }
- return;
-}
diff --git a/mpack/Rlascl.cpp b/mpack/Rlascl.cpp
deleted file mode 100644
index f178995..0000000
--- a/mpack/Rlascl.cpp
+++ /dev/null
@@ -1,216 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlascl.cpp,v 1.7 2009/09/25 04:00:39 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-#define MTRUE 1
-#define MFALSE 0
-
-void
-Rlascl(const char *type, mpackint kl, mpackint ku, mpf_class cfrom, mpf_class cto, mpackint m,
- mpackint n, mpf_class * A, mpackint lda, mpackint *info)
-{
- mpackint i, j, k1, k2, k3, k4;
- mpackint itype;
- mpf_class One = 1.0, Zero = 0.0;
- mpf_class bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum;
- mpackint done = MFALSE;
-
- *info = 0;
- if (Mlsame_gmp(type, "G")) {
- itype = 0;
- } else if (Mlsame_gmp(type, "L")) {
- itype = 1;
- } else if (Mlsame_gmp(type, "U")) {
- itype = 2;
- } else if (Mlsame_gmp(type, "H")) {
- itype = 3;
- } else if (Mlsame_gmp(type, "B")) {
- itype = 4;
- } else if (Mlsame_gmp(type, "Q")) {
- itype = 5;
- } else if (Mlsame_gmp(type, "Z")) {
- itype = 6;
- } else {
- itype = -1;
- }
- if (itype == -1) {
- *info = -1;
- } else if (cfrom == Zero) {
- *info = -4;
- } else if (m < 0) {
- *info = -6;
- } else if (n < 0 || (itype == 4 && n != m) || (itype == 5 && n != m) ) {
- *info = -7;
- } else if (itype <= 3 && lda < max((mpackint)1, m)) {
- *info = -9;
- } else if (itype >= 4) {
- if (kl < 0 || kl > max(m - 1, (mpackint)0)) {
- *info = -2;
- } else {
- if (ku < 0 || ku > max(n - 1, (mpackint)0) || ((itype == 4 || itype == 5) &&
- kl != ku)) {
- *info = -3;
- } else if ( (itype == 4 && lda < kl + 1) || (itype == 5 && lda < ku + 1)
- || (itype == 6 && lda < (kl * 2) + ku + 1)) {
- *info = -9;
- }
- }
- }
-
- if (*info != 0) {
- Mxerbla_gmp("Rlascl", -(*info));
- return;
- }
-//Quick return if possible
- if (n == 0 || m == 0) {
- return;
- }
-//Get machine parameters
- smlnum = Rlamch_gmp("S");
- bignum = One / smlnum;
-
- cfromc = cfrom;
- ctoc = cto;
-
- while (done == MFALSE) {
- cfrom1 = cfromc * smlnum;
- cto1 = ctoc / bignum;
- if (abs(cfrom1) > abs(ctoc) && ctoc != Zero) {
- mul = smlnum;
- done = MFALSE;
- cfromc = cfrom1;
- } else if (abs(cto1) > abs(cfromc)) {
- mul = bignum;
- done = MFALSE;
- ctoc = cto1;
- } else {
- mul = ctoc / cfromc;
- done = MTRUE;
- }
- if (itype == 0) {
-//Full matrix
- for (j = 0; j < n; j++) {
- for (i = 0; i < m; i++) {
- A[i + j * lda] = A[i + j * lda] * mul;
- }
- }
- } else if (itype == 1) {
-//Lower triangular matrix
- for (j = 0; j < n; j++) {
- for (i = j; i < m; i++) {
- A[i + j * lda] = A[i + j * lda] * mul;
- }
- }
- } else if (itype == 2) {
-//Upper triangular matrix
- for (j = 0; j < n; j++) {
- for (i = 0; i <= min(j, m - 1); i++) {
- A[i + j * lda] = A[i + j * lda] * mul;
- }
- }
- } else if (itype == 3) {
-//Upper Hessenberg matrix
- for (j = 0; j < n; j++) {
- for (i = 0; i <= min(j + 1, m - 1); i++) {
- A[i + j * lda] = A[i + j * lda] * mul;
- }
- }
- } else if (itype == 4) {
-//Lower half of a symmetric band matrix
- k3 = kl + 1;
- k4 = n + 1;
- for (j = 0; j < n; j++) {
- for (i = 0; i < min(k3, k4 - j - 1); i++) {
- A[i + j * lda] *= mul;
- }
- }
-
- } else if (itype == 5) {
-//Upper half of a symmetric band matrix
- k1 = ku + 2;
- k3 = ku + 1;
- for (j = 0; j < n; j++) {
- for (i = max(k1 - j - 1, (mpackint)1) - 1; i < k3; i++) {
- A[i + j * lda] = A[i + j * lda] * mul;
- }
- }
- } else if (itype == 6) {
-//Band matrix
- k1 = kl + ku + 2;
- k2 = kl + 1;
- k3 = (kl << 1) + ku + 1;
- k4 = kl + ku + 1 + m;
- for (j = 0; j < n; j++) {
- for (i = max(k1 - j - 1, k2) - 1; i < min(k3, k4 - j - 1); i++) {
- A[i + j * lda] = A[i + j * lda] * mul;
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rlaset.cpp b/mpack/Rlaset.cpp
deleted file mode 100644
index 15091ec..0000000
--- a/mpack/Rlaset.cpp
+++ /dev/null
@@ -1,105 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlaset.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rlaset(const char *uplo, mpackint m, mpackint n, mpf_class alpha, mpf_class beta,
- mpf_class * A, mpackint lda)
-{
- mpackint i, j;
-
- if (Mlsame_gmp(uplo, "U")) {
-//Set the strictly upper triangular or trapezoidal part of the
-//array to ALPHA.
- for (j = 1; j < n; j++) {
- for (i = 0; i < min(j, m); i++) {
- A[i + j * lda] = alpha;
- }
- }
- } else if (Mlsame_gmp(uplo, "L")) {
-//Set the strictly lower triangular or trapezoidal part of the
-//array to ALPHA.
- for (j = 0; j < min(m, n); j++) {
- for (i = j + 1; i < m; i++) {
- A[i + j * lda] = alpha;
- }
- }
- } else {
-//Set the leading m-by-n submatrix to ALPHA.
- for (j = 0; j < n; j++) {
- for (i = 0; i < m; i++) {
- A[i + j * lda] = alpha;
- }
- }
- }
-//Set the first min(M,N) diagonal elements to BETA.
- for (i = 0; i < min(m, n); i++) {
- A[i + i * lda] = beta;
- }
- return;
-}
diff --git a/mpack/Rlasr.cpp b/mpack/Rlasr.cpp
deleted file mode 100644
index 890a00a..0000000
--- a/mpack/Rlasr.cpp
+++ /dev/null
@@ -1,289 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlasr.cpp,v 1.5 2009/09/22 20:33:23 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rlasr(const char *side, const char *pivot, const char *direct, mpackint m,
- mpackint n, mpf_class * c, mpf_class * s, mpf_class * A, mpackint lda)
-{
- mpf_class Zero = 0.0;
- mpf_class One = 1.0;
- mpf_class ctemp, stemp, temp;
- mpackint info;
- mpackint i, j;
-
- info = 0;
- if (!(Mlsame_gmp(side, "L") || Mlsame_gmp(side, "R")))
- info = 1;
- else if (!(Mlsame_gmp(pivot, "V") || Mlsame_gmp(pivot, "T")
- || Mlsame_gmp(pivot, "B")))
- info = 2;
- else if (!(Mlsame_gmp(direct, "F") || Mlsame_gmp(direct, "B")))
- info = 3;
- else if (m < 0)
- info = 4;
- else if (n < 0)
- info = 5;
- else if (lda < max((mpackint)1, m))
- info = 9;
- if (info != 0) {
- Mxerbla_gmp("Rlasr ", info);
- return;
- }
-//Quick return if possible
- if (m == 0 || n == 0) {
- return;
- }
-
- if (Mlsame_gmp(side, "L")) {
-//Form P * A
- if (Mlsame_gmp(pivot, "V")) {
- if (Mlsame_gmp(direct, "F")) {
- for (j = 0; j < m - 1; j++) {
- ctemp = c[j];
- stemp = s[j];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < n; i++) {
- temp = A[(j + 1) + i * lda];
- A[(j + 1) + i * lda] = ctemp * temp - stemp *
- A[j + i * lda];
- A[j + i * lda] =
- stemp * temp + ctemp * A[j + i * lda];
- }
- }
- }
- } else if (Mlsame_gmp(direct, "B")) {
- for (j = m - 2; j >= 0; j--) {
- ctemp = c[j];
- stemp = s[j];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < n; i++) {
- temp = A[(j + 1) + i * lda];
- A[(j + 1) + i * lda] = ctemp * temp - stemp *
- A[j + i * lda];
- A[j + i * lda] = stemp * temp + ctemp * A[j
- + i * lda];
- }
- }
- }
- }
- }
-
- else if (Mlsame_gmp(pivot, "T")) {
- if (Mlsame_gmp(direct, "F")) {
- for (j = 1; j < m; j++) {
- ctemp = c[j - 1];
- stemp = s[j - 1];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < n; i++) {
- temp = A[j + i * lda];
- A[j + i * lda] = ctemp * temp - stemp * A[i * lda];
- A[i * lda] = stemp * temp + ctemp * A[i * lda];
- }
- }
- }
- } else if (Mlsame_gmp(direct, "B")) {
- for (j = m - 1; j >= 1; j--) {
- ctemp = c[j - 1];
- stemp = s[j - 1];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < n; i++) {
- temp = A[j + i * lda];
- A[j + i * lda] = ctemp * temp - stemp * A[i * lda];
- A[i * lda] = stemp * temp + ctemp * A[i * lda];
- }
- }
- }
- }
- }
-
- else if (Mlsame_gmp(pivot, "B")) {
- if (Mlsame_gmp(direct, "F")) {
- for (j = 0; j < m - 1; j++) {
- ctemp = c[j];
- stemp = s[j];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < n; i++) {
- temp = A[j + i * lda];
- A[j + i * lda] = stemp * A[(m - 1) + i * lda]
- + ctemp * temp;
- A[(m - 1) + i * lda] =
- ctemp * A[(m - 1) + i * lda] - stemp * temp;
- }
- }
- }
- } else if (Mlsame_gmp(direct, "B")) {
- for (j = m - 2; j >= 0; j--) {
- ctemp = c[j];
- stemp = s[j];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < n; i++) {
- temp = A[j + i * lda];
- A[j + i * lda] = stemp * A[(m - 1) + i * lda]
- + ctemp * temp;
- A[(m - 1) + i * lda] =
- ctemp * A[(m - 1) + i * lda] - stemp * temp;
- }
- }
- }
- }
- }
- }
-
- else if (Mlsame_gmp(side, "R")) {
-//Form A * P'
- if (Mlsame_gmp(pivot, "V")) {
- if (Mlsame_gmp(direct, "F")) {
- for (j = 0; j < n - 1; j++) {
- ctemp = c[j];
- stemp = s[j];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < m; i++) {
- temp = A[i + (j + 1) * lda];
- A[i + (j + 1) * lda] =
- ctemp * temp - stemp * A[i + j * lda];
- A[i + j * lda] =
- stemp * temp + ctemp * A[i + j * lda];
- }
- }
- }
- } else if (Mlsame_gmp(direct, "B")) {
- for (j = n - 2; j >= 0; j--) {
- ctemp = c[j];
- stemp = s[j];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < m; i++) {
- temp = A[i + (j + 1) * lda];
- A[i + (j + 1) * lda] =
- ctemp * temp - stemp * A[i + j * lda];
- A[i + j * lda] =
- stemp * temp + ctemp * A[i + j * lda];
- }
- }
- }
- }
- } else if (Mlsame_gmp(pivot, "T")) {
- if (Mlsame_gmp(direct, "F")) {
- for (j = 1; j < n; j++) {
- ctemp = c[j - 1];
- stemp = s[j - 1];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < m; i++) {
- temp = A[i + j * lda];
- A[i + j * lda] = ctemp * temp - stemp * A[i];
- A[i] = stemp * temp + ctemp * A[i];
- }
- }
- }
- } else if (Mlsame_gmp(direct, "B")) {
- for (j = n - 1; j >= 1; j--) {
- ctemp = c[j - 1];
- stemp = s[j - 1];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < m; i++) {
- temp = A[i + j * lda];
- A[i + j * lda] = ctemp * temp - stemp * A[i];
- A[i] = stemp * temp + ctemp * A[i];
- }
- }
- }
- }
- } else if (Mlsame_gmp(pivot, "B")) {
- if (Mlsame_gmp(direct, "F")) {
- for (j = 0; j < n - 1; j++) {
- ctemp = c[j];
- stemp = s[j];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < m; i++) {
- temp = A[i + j * lda];
- A[i + j * lda] = stemp * A[i + (n - 1) * lda]
- + ctemp * temp;
- A[i + (n - 1) * lda] =
- ctemp * A[i + (n - 1) * lda] - stemp * temp;
- }
- }
- }
- } else if (Mlsame_gmp(direct, "B")) {
- for (j = n - 2; j >= 0; j--) {
- ctemp = c[j];
- stemp = s[j];
- if (ctemp != One || stemp != Zero) {
- for (i = 0; i < m; i++) {
- temp = A[i + j * lda];
- A[i + j * lda] = stemp * A[i + (n - 1) * lda]
- + ctemp * temp;
- A[i + (n - 1) * lda] =
- ctemp * A[i + (n - 1) * lda] - stemp * temp;
- }
- }
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rlasrt.cpp b/mpack/Rlasrt.cpp
deleted file mode 100644
index f2cd50e..0000000
--- a/mpack/Rlasrt.cpp
+++ /dev/null
@@ -1,79 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlasrt.cpp,v 1.7 2009/09/25 04:00:39 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <stdlib.h>
-
-int
-compare_mpf_gt(const mpf_class * a, const mpf_class * b)
-{
- if (*a > *b)
- return 1;
- if (*a == *b)
- return 0;
- if (*a < *b)
- return -1;
- return 0; //never occurs
-}
-
-int
-compare_mpf_lt(const mpf_class * a, const mpf_class * b)
-{
- if (*a > *b)
- return -1;
- if (*a == *b)
- return 0;
- if (*a < *b)
- return 1;
- return 0; //never occurs
-}
-
-void
-Rlasrt(const char *id, mpackint n, mpf_class * d, mpackint *info)
-{
- //Error check
- if (!Mlsame_gmp(id, "I") && !Mlsame_gmp(id, "D")) {
- *info = -1;
- Mxerbla_gmp("Rlasrt", -(*info));
- return;
- }
- if (n < 0) {
- *info = -2;
- Mxerbla_gmp("Rlasrt", -(*info));
- return;
- }
- if (Mlsame_gmp(id, "I")) {
- qsort(d, n, sizeof(mpf_class), (int (*)(const void *, const void *))compare_mpf_gt);
- }
- if (Mlsame_gmp(id, "d")) {
- qsort(d, n, sizeof(mpf_class), (int (*)(const void *, const void *))compare_mpf_lt);
- }
- *info = 0;
-}
diff --git a/mpack/Rlassq.cpp b/mpack/Rlassq.cpp
deleted file mode 100644
index 0562192..0000000
--- a/mpack/Rlassq.cpp
+++ /dev/null
@@ -1,95 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlassq.cpp,v 1.2 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-//http://www.netlib.org/lapack/double/dlassq.f
-void
-Rlassq(mpackint n, mpf_class * x, mpackint incx, mpf_class * scale, mpf_class * sumsq)
-{
- mpackint ix;
- mpf_class Zero = 0.0, One = 1.0;
- mpf_class absxi;
-
- if (n > 0) {
- for (ix = 0; ix <= (n - 1) * incx; ix += incx) {
- if (x[ix] != Zero) {
- absxi = abs(x[ix]);
- if ((*scale) < absxi) {
- (*sumsq) =
- One +
- (*sumsq) * ((*scale) / absxi) * ((*scale) / absxi);
- (*scale) = absxi;
- } else {
- (*sumsq) =
- (*sumsq) + (absxi / (*scale)) * (absxi / (*scale));
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rlatrd.cpp b/mpack/Rlatrd.cpp
deleted file mode 100644
index cd2907d..0000000
--- a/mpack/Rlatrd.cpp
+++ /dev/null
@@ -1,167 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rlatrd.cpp,v 1.3 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rlatrd(const char *uplo, mpackint n, mpackint nb, mpf_class * A, mpackint lda, mpf_class * e,
- mpf_class * tau, mpf_class * w, mpackint ldw)
-{
- mpackint i, iw;
- mpf_class Zero = 0.0, Half = 0.5, One = 1.0;
- mpf_class alpha;
-
-//Quick return if possible
- if (n <= 0)
- return;
-
- if (Mlsame_gmp(uplo, "U")) {
-//Reduce last NB columns of upper triangle
- for (i = n; i >= n - nb + 1; i--) {
- iw = i - n + nb;
- if (i < n) {
-//Update A(1:i,i)
- Rgemv("No transpose", i, n - i, -One, &A[0 + i * lda],
- lda, &w[(i - 1) + iw * ldw], ldw, One,
- &A[0 + (i - 1) * lda], 1);
- Rgemv("No transpose", i, n - i, -One, &w[0 + iw * ldw], ldw,
- &A[(i - 1) + i * lda], lda, One, &A[0 + (i - 1) * lda], 1);
- }
- if (i > 1) {
-//Generate elementary reflector H(i) to annihilate
-//A(1:i-2,i)
- Rlarfg(i - 1, &A[(i - 2) + (i - 1) * lda],
- &A[0 + (i - 1) * lda], 1, &tau[i - 2]);
- e[i - 2] = A[(i - 2) + (i - 1) * lda];
- A[(i - 2) + (i - 1) * lda] = One;
-//Compute W(1:i-1,i)
- Rsymv("Upper", i - 1, One, &A[0], lda, &A[0 + (i - 1) * lda],
- 1, Zero, &w[0 + (iw - 1) * ldw], 1);
- if (i < n) {
- Rgemv("Transpose", i - 1, n - i, One, &w[0 + iw *
- ldw], ldw, &A[0 + (i - 1) * lda], 1, Zero,
- &w[i + (iw - 1) * ldw], 1);
- Rgemv("No transpose", i - 1, n - i, -One,
- &A[0 + i * lda], lda, &w[i + (iw - 1) * ldw], 1,
- One, &w[0 + (iw - 1) * ldw], 1);
- Rgemv("Transpose", i - 1, n - i, One,
- &A[0 + i * lda], lda, &A[0 + (i - 1) * lda], 1, Zero,
- &w[i + (iw - 1) * ldw], 1);
- Rgemv("No transpose", i - 1, n - i, -One,
- &w[0 + iw * ldw], ldw, &w[i + (iw - 1) * ldw], 1,
- One, &w[0 + (iw - 1) * ldw], 1);
- }
- Rscal(i - 1, tau[i - 2], &w[0 + (iw - 1) * ldw], 1);
- alpha =
- -Half * tau[i - 2] * Rdot(i - 1, &w[0 + (iw - 1) * ldw], 1,
- &A[0 + (i - 1) * lda], 1);
- Raxpy(i - 1, alpha, &A[0 + (i - 1) * lda], 1,
- &w[0 + (iw - 1) * ldw], 1);
-
- }
- }
- } else {
-//Reduce first NB columns of lower triangle
- for (i = 1; i <= nb; i++) {
-//Update A(i:n,i)
- Rgemv("No transpose", n - i + 1, i - 1, -One,
- &A[(i - 1) + 0 * lda], lda, &w[(i - 1) + 0 * ldw], ldw, One,
- &A[(i - 1) + (i - 1) * lda], 1);
- Rgemv("No transpose", n - i + 1, i - 1, -One,
- &w[(i - 1) + 0 * ldw], ldw, &A[(i - 1) + 0 * lda], lda, One,
- &A[(i - 1) + (i - 1) * lda], 1);
- if (i < n) {
-//Generate elementary reflector H(i) to annihilate
-//A(i+2:n,i)
- Rlarfg(n - i, &A[i + (i - 1) * lda], &A[min(i + 2,
- n) - 1 + (i - 1) * lda], 1, &tau[i - 1]);
- e[i - 1] = A[i + (i - 1) * lda];
- A[i + (i - 1) * lda] = One;
-
-//Compute W(i+1:n,i)
- Rsymv("Lower", n - i, One, &A[i + i * lda],
- lda, &A[i + (i - 1) * lda], 1, Zero, &w[i + (i - 1) * ldw],
- 1);
- Rgemv("Transpose", n - i, i - 1, One, &w[i + 0 * ldw],
- ldw, &A[i + (i - 1) * lda], 1, Zero, &w[0 + (i - 1) * ldw],
- 1);
- Rgemv("No transpose", n - i, i - 1, -One, &A[i + 0 * lda], lda,
- &w[0 + (i - 1) * ldw], 1, One, &w[i + (i - 1) * ldw], 1);
- Rgemv("Transpose", n - i, i - 1, One, &A[i + 0 * lda], lda,
- &A[i + (i - 1) * lda], 1, Zero, &w[0 + (i - 1) * ldw], 1);
- Rgemv("No transpose", n - i, i - 1, -One, &w[i + 0 * ldw], ldw,
- &w[0 + (i - 1) * ldw], 1, One, &w[i + (i - 1) * ldw], 1);
- Rscal(n - i, tau[i - 1], &w[i + (i - 1) * ldw], 1);
- alpha = -Half * tau[i - 1] * Rdot(n - i, &w[i + (i - 1) *
- ldw], 1, &A[i + (i - 1) * lda], 1);
- Raxpy(n - i, alpha, &A[i + (i - 1) * lda], 1,
- &w[i + (i - 1) * ldw], 1);
- }
- }
- }
- return;
-}
diff --git a/mpack/Rnrm2.cpp b/mpack/Rnrm2.cpp
deleted file mode 100644
index 87a3656..0000000
--- a/mpack/Rnrm2.cpp
+++ /dev/null
@@ -1,102 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rnrm2.cpp,v 1.2 2009/09/12 21:39:52 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dnrm2.f
-Rnrm2 returns the euclidean norm of a vector, sqrt( x'*x ).
-*/
-
-#include <mblas_gmp.h>
-
-mpf_class
-Rnrm2(mpackint n, mpf_class * x, mpackint incx)
-{
- mpf_class Zero = 0.0, One = 1.0;
-
- mpf_class norm, scale, ssq, absxi;
-
- if (n < 1 || incx < 1) {
- norm = Zero;
- } else if (n == 1) {
- norm = abs(x[0]);
- } else {
- scale = Zero;
- ssq = One;
- for (mpackint ix = 0; ix <= (n - 1) * incx; ix = ix + incx) {
- if (x[ix] != Zero) {
- absxi = abs(x[ix]);
- if (scale < absxi) {
- ssq = One + ssq * (scale / absxi) * (scale / absxi);
- scale = absxi;
- } else {
- ssq = ssq + (absxi / scale) * (absxi / scale);
- }
- }
- }
- norm = scale * sqrt(ssq);
- }
- return norm;
-}
diff --git a/mpack/Rorg2l.cpp b/mpack/Rorg2l.cpp
deleted file mode 100644
index b93127f..0000000
--- a/mpack/Rorg2l.cpp
+++ /dev/null
@@ -1,117 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rorg2l.cpp,v 1.6 2009/09/22 22:46:17 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rorg2l(mpackint m, mpackint n, mpackint k, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint *info)
-{
- mpackint i, ii, j, l;
- mpf_class Zero = 0.0, One = 1.0;
-
- *info = 0;
- if (m < 0) {
- *info = -1;
- } else if (n < 0 || n > m) {
- *info = -2;
- } else if (k < 0 || k > n) {
- *info = -3;
- } else if (lda < max((mpackint)1, m)) {
- *info = -5;
- }
- if (*info != 0) {
- Mxerbla_gmp("Rorg2l", -(*info));
- return;
- }
-//quick return if possible
- if (n <= 0)
- return;
-
-//Initialise columns 1:n-k to columns of the unit matrix
- for (j = 0; j < n - k; j++) {
- for (l = 0; l < m; l++) {
- A[l + j * lda] = Zero;
- }
- A[m - n + j + j * lda] = One;
- }
-
- for (i = 1; i <= k; i++) {
- ii = n - k + i;
-//Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
- A[(m - n + ii - 1) + (ii - 1) * lda] = One;
- Rlarf("Left", m - n + ii, ii - 1, &A[0 + (ii - 1) * lda], 1,
- tau[i - 1], A, lda, work);
- Rscal(m - n + ii - 1, -tau[i - 1], &A[0 + (ii - 1) * lda], 1);
- A[(m - n + ii - 1) + (ii - 1) * lda] = One - tau[i - 1];
-//Set A(m-k+i+1:m,n-k+i) to zero
- for (l = m - n + ii + 1; l <= m; l++) {
- A[(l - 1) + (ii - 1) * lda] = Zero;
- }
- }
- return;
-}
diff --git a/mpack/Rorg2r.cpp b/mpack/Rorg2r.cpp
deleted file mode 100644
index 4db20b6..0000000
--- a/mpack/Rorg2r.cpp
+++ /dev/null
@@ -1,120 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rorg2r.cpp,v 1.6 2009/09/22 22:46:17 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rorg2r(mpackint m, mpackint n, mpackint k, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint *info)
-{
- mpackint i, j, l;
- mpf_class One = 1.0, Zero = 0.0;
-
- *info = 0;
- if (m < 0) {
- *info = -1;
- } else if (n < 0 || n > m) {
- *info = -2;
- } else if (k < 0 || k > n) {
- *info = -3;
- } else if (lda < max((mpackint)1, m)) {
- *info = -5;
- }
- if (*info != 0) {
- Mxerbla_gmp("Rorg2r", -(*info));
- return;
- }
-//Quick return if possible
- if (n <= 0)
- return;
-
-//Initialise columns k+1:n to columns of the unit matrix
- for (j = k; j < n; j++) {
- for (l = 0; l < m; l++) {
- A[l + j * lda] = Zero;
- }
- A[j + j * lda] = One;
- }
- for (i = k; i >= 1; i--) {
-//Apply H(i) to A(i:m,i:n) from the left
- if (i < n) {
- A[(i - 1) + (i - 1) * lda] = One;
- Rlarf("Left", m - i + 1, n - i, &A[(i - 1) + (i - 1) * lda], 1,
- tau[i - 1], &A[(i - 1) + i * lda], lda, work);
- }
- if (i < m) {
- Rscal(m - i, -tau[i - 1], &A[i + (i - 1) * lda], 1);
- }
- A[(i - 1) + (i - 1) * lda] = One - tau[i - 1];
-
-//Set A(1:i-1,i) to zero
- for (l = 0; l < i - 1; l++) {
- A[l + (i - 1) * lda] = Zero;
- }
- }
- return;
-}
diff --git a/mpack/Rorgql.cpp b/mpack/Rorgql.cpp
deleted file mode 100644
index d041fdb..0000000
--- a/mpack/Rorgql.cpp
+++ /dev/null
@@ -1,177 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rorgql.cpp,v 1.7 2009/09/25 04:00:39 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rorgql(mpackint m, mpackint n, mpackint k, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint lwork, mpackint *info)
-{
- mpf_class Zero = 0.0, One = 1.0;
- mpackint nbmin, nx, iws, nb, lwkopt, lquery, kk;
- mpackint i, j, l, iinfo, ldwork, ib;
-
-//Test the input arguments
- *info = 0;
- if (lwork == -1)
- lquery = 1;
- else
- lquery = 0;
-
- if (m < 0) {
- *info = -1;
- } else if (n < 0 || n > m) {
- *info = -2;
- } else if (k < 0 || k > n) {
- *info = -3;
- } else if (lda < max((mpackint)1, m)) {
- *info = -5;
- }
-
- if (*info == 0) {
- if (n == 0) {
- lwkopt = 1;
- } else {
- nb = iMlaenv_gmp(1, "Rorgql", " ", m, n, k, -1);
- lwkopt = n * nb;
- }
- work[0] = (double)lwkopt; //needs cast mpackint to mpf
- if (lwork < max((mpackint)1, n) && !lquery) {
- *info = -8;
- }
- }
- if (*info != 0) {
- Mxerbla_gmp("Rorgql", -(*info));
- return;
- } else if (lquery) {
- return;
- }
-//Quick return if possible
- if (n <= 0)
- return;
- nbmin = 2;
- nx = 0;
- iws = n;
- if (nb > 1 && nb < k) {
-//Determine when to cross over from blocked to unblocked code.
- nx = max((mpackint)0, iMlaenv_gmp(3, "Rorgql", " ", m, n, k, -1));
- if (nx < k) {
-//Determine if workspace is large enough for blocked code.
- ldwork = n;
- iws = ldwork * nb;
- if (lwork < iws) {
-//Not enough workspace to use optimal NB: reduce NB and
-//determine the minimum value of NB.
- nb = lwork / ldwork;
- nbmin = max((mpackint)2, iMlaenv_gmp(2, "Rorgql", " ", m, n, k, -1));
- }
- }
- }
- if (nb >= nbmin && nb < k && nx < k) {
-//Use blocked code after the first block.
-//The last kk columns are handled by the block method.
- kk = min(k, (k - nx + nb - 1) / nb * nb);
-//Set A(m-kk+1:m,1:n-kk) to zero.
- for (j = 1; j <= n - kk; j++) {
- for (i = m - kk + 1; i <= m; i++) {
- A[(i - 1) + (j - 1) * lda] = Zero;
- }
- }
- } else {
- kk = 0;
- }
-//Use unblocked code for the first or only block.
- Rorg2l(m - kk, n - kk, k - kk, A, lda, tau, work, &iinfo);
- if (kk > 0) {
- for (i = k - kk + 1; i <= k; i = i + nb) {
- ib = min(nb, k - i + 1);
- if (n - k + i > 1) {
-//Form the triangular factor of the block reflector
-//H = H(i+ib-1) . . . H(i+1) H(i)
- Rlarft("Backward", "Columnwise", m - k + i + ib - 1, ib,
- &A[0 + (n - k + i - 1) * lda], lda, &tau[i - 1], work,
- ldwork);
-//Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
- Rlarfb("Left", "No transpose", "Backward", "Columnwise",
- m - k + i + ib - 1, n - k + i - 1, ib,
- &A[0 + (n - k + i - 1) * lda], lda, work, ldwork, A,
- lda, &work[ib], ldwork);
- }
-//Apply H to rows 1:m-k+i+ib-1 of current block
- Rorg2l(m - k + i + ib - 1, ib, ib, &A[0 + (n - k + i - 1) * lda],
- lda, &tau[i - 1], work, &iinfo);
-//Set rows m-k+i+ib:m of current block to zero
- for (j = n - k + i; j <= n - k + i + ib - 1; j++) {
- for (l = m - k + i + ib; l <= m; l++) {
- A[(l - 1) + (j - 1) * lda] = Zero;
- }
- }
- }
- }
- work[0] = (double)iws; //needs cast mpackint to mpf
- return;
-}
diff --git a/mpack/Rorgqr.cpp b/mpack/Rorgqr.cpp
deleted file mode 100644
index 2da89b9..0000000
--- a/mpack/Rorgqr.cpp
+++ /dev/null
@@ -1,177 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rorgqr.cpp,v 1.7 2009/09/22 21:22:09 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rorgqr(mpackint m, mpackint n, mpackint k, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint lwork, mpackint *info)
-{
- mpf_class Zero = 0.0, One = 1.0;
- mpackint nbmin, nx, iws, nb, lwkopt, lquery, ki, kk;
- mpackint i, j, l, iinfo, ldwork, ib;
-
-//Test the input arguments
- *info = 0;
- nb = iMlaenv_gmp(1, "Rorgqr", " ", m, n, k, -1);
-
- lwkopt = max((mpackint)1, n) * nb;
- work[0] = (double)lwkopt; //needs cast mpackint to mpf
- if (lwork == -1)
- lquery = 1;
- else
- lquery = 0;
-
- if (m < 0) {
- *info = -1;
- } else if (n < 0 || n > m) {
- *info = -2;
- } else if (k < 0 || k > n) {
- *info = -3;
- } else if (lda < max((mpackint)1, m)) {
- *info = -5;
- } else if (lwork < max((mpackint)1, n) && !lquery) {
- *info = -8;
- }
- if (*info != 0) {
- Mxerbla_gmp("Rorgqr", -(*info));
- return;
- } else if (lquery) {
- return;
- }
- if (n <= 0) {
- work[0] = One;
- return;
- }
-
- nbmin = 2;
- nx = 0;
- iws = n;
- if (nb > 1 && nb < k) {
-//Determine when to cross over from blocked to unblocked code.
- nx = max((mpackint)0, iMlaenv_gmp(3, "Rorgqr", " ", m, n, k, -1));
- if (nx < k) {
-//Determine if workspace is large enough for blocked code.
- ldwork = n;
- iws = ldwork * nb;
- if (lwork < iws) {
-//Not enough workspace to use optimal NB: reduce NB and
-//determine the minimum value of NB.
- nb = lwork / ldwork;
- nbmin = max((mpackint)2, iMlaenv_gmp(2, "Rorgqr", " ", m, n, k, -1));
- }
- }
- }
- if (nb >= nbmin && nb < k && nx < k) {
-//Use blocked code after the last block.
-//The first kk columns are handled by the block method.
- ki = (k - nx - 1) / nb * nb;
- kk = min(k, ki + nb);
-//Set A(1:kk,kk+1:n) to zero.
- for (j = kk + 1; j <= n; j++) {
- for (i = 1; i <= kk; i++) {
- A[(i - 1) + (j - 1) * lda] = Zero;
- }
- }
- } else {
- kk = 0;
- }
-//Use unblocked code for the last or only block.
- if (kk < n) {
- Rorg2r(m - kk, n - kk, k - kk, &A[kk + kk * lda], lda,
- &tau[kk], &work[0], &iinfo);
- }
- if (kk > 0) {
-//Use blocked code
- for (i = ki + 1; i >= 1; i = i - nb) {
- ib = min(nb, k - i + 1);
- if (i + ib <= n) {
-//Form the triangular factor of the block reflector
-//H = H(i) H(i+1) . . . H(i+ib-1)
- Rlarft("Forward", "Columnwise", m - i + 1, ib,
- &A[(i - 1) + (i - 1) * lda], lda, &tau[i - 1], work,
- ldwork);
-//Apply H to A(i:m,i+ib:n) from the left
- Rlarfb("Left", "No transpose", "Forward", "Columnwise",
- m - i + 1, n - i - ib + 1, ib, &A[(i - 1) + (i - 1) * lda],
- lda, work, ldwork, &A[(i - 1) + (i + ib - 1) * lda], lda,
- &work[ib], ldwork);
- }
-//Apply H to rows i:m of current block
- Rorg2r(m - i + 1, ib, ib, &A[(i - 1) + (i - 1) * lda], lda,
- &tau[i - 1], work, &iinfo);
-//Set rows 1:i-1 of current block to zero
- for (j = i; j <= i + ib - 1; j++) {
- for (l = 1; l <= i - 1; l++) {
- A[(l - 1) + (j - 1) * lda] = Zero;
- }
- }
- }
- }
- work[0] = (double)iws; //needs cast mpackint to mpf
- return;
-}
diff --git a/mpack/Rorgtr.cpp b/mpack/Rorgtr.cpp
deleted file mode 100644
index 68130a7..0000000
--- a/mpack/Rorgtr.cpp
+++ /dev/null
@@ -1,157 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rorgtr.cpp,v 1.6 2009/09/22 22:46:17 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rorgtr(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint lwork, mpackint *info)
-{
-
- mpf_class Zero = 0.0, One = 1.0;
- mpackint lquery, lwkopt, iinfo, upper, nb;
- mpackint i, j;
-
- *info = 0;
- if (lwork == -1)
- lquery = 1;
- else
- lquery = 0;
-
- upper = Mlsame_gmp(uplo, "U");
- if (!upper && !Mlsame_gmp(uplo, "L")) {
- *info = -1;
- } else if (n < 0) {
- *info = -2;
- } else if (lda < max((mpackint)1, n)) {
- *info = -4;
- } else {
- if (lwork < max((mpackint)1, n - 1) && !lquery) {
- *info = -7;
- }
- }
- if (*info == 0) {
- if (upper) {
- nb = iMlaenv_gmp(1, "Rorgql", " ", n - 1, n - 1, n - 1, -1);
- } else {
- nb = iMlaenv_gmp(1, "Rorgqr", " ", n - 1, n - 1, n - 1, -1);
- }
- lwkopt = max((mpackint)1, n - 1) * nb;
- work[0] = (double)lwkopt; //needs cast from double to mpf
- }
- if (*info != 0) {
- Mxerbla_gmp("Rorgtr", -(*info));
- return;
- } else if (lquery) {
- return;
- }
-//Quick return if possible
- if (n == 0) {
- work[0] = One;
- return;
- }
- if (upper) {
-//Q was determined by a call to DSYTRD with UPLO = 'U'
-//Shift the vectors which define the elementary reflectors one
-//column to the left, and set the last row and column of Q to
-//those of the unit matrix
- for (j = 1; j <= n - 1; j++) {
- for (i = 1; i <= j - 1; i++) {
- A[(i - 1) + (j - 1) * lda] = A[(i - 1) + j * lda];
- }
- A[(n - 1) + (j - 1) * lda] = Zero;
- }
- for (i = 1; i <= n - 1; i++) {
- A[(i - 1) + (n - 1) * lda] = Zero;
- }
- A[(n - 1) + (n - 1) * lda] = One;
-//Generate Q(1:n-1,1:n-1)
- Rorgql(n - 1, n - 1, n - 1, A, lda, tau, work, lwork, &iinfo);
- } else {
-//Q was determined by a call to DSYTRD with UPLO = 'L'.
-//Shift the vectors which define the elementary reflectors one
-//column to the right, and set the first row and column of Q to
-//those of the unit matrix
- for (j = n; j >= 2; j--) {
- A[0 + (j - 1) * lda] = Zero;
- for (i = j + 1; i <= n; i++) {
- A[(i - 1) + (j - 1) * lda] = A[(i - 1) + (j - 2) * lda];
- }
- }
- A[0 + 0 * lda] = One;
- for (i = 2; i <= n; i++) {
- A[(i - 1) + 0 * lda] = Zero;
- }
- if (n > 1) {
-//Generate Q(2:n,2:n)
- Rorgqr(n - 1, n - 1, n - 1, &A[1 + (1 * lda)], lda, tau,
- work, lwork, &iinfo);
- }
- }
- work[0] = (double)lwkopt; //needs cast from double to mpf
- return;
-}
diff --git a/mpack/Rpotf2.cpp b/mpack/Rpotf2.cpp
deleted file mode 100644
index 188eabb..0000000
--- a/mpack/Rpotf2.cpp
+++ /dev/null
@@ -1,139 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rpotf2.cpp,v 1.7 2009/09/25 04:00:39 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <stdlib.h>
-
-void
-Rpotf2(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpackint *info)
-{
- mpackint j, upper, success = 1;
- mpf_class ajj;
- mpf_class Zero = 0.0;
- mpf_class One = 1.0;
-
- *info = 0;
- upper = Mlsame_gmp(uplo, "U");
- if (!upper && !Mlsame_gmp(uplo, "L")) {
- *info = -1;
- } else if (n < 0) {
- *info = -2;
- } else if (lda < max((mpackint)1, n)) {
- *info = -4;
- }
- if (*info != 0) {
- Mxerbla_gmp("Rpotf2", -(*info));
- return;
- }
-//Quick return if possible
- if (n == 0)
- return;
-
- if (upper) {
-//Compute the Cholesky factorization A = U'*U.
- for (j = 0; j < n; j++) {
-//Compute U(J,J) and test for non-positive-definiteness.
- ajj = A[j + j * lda] - Rdot(j, &A[j * lda], 1, &A[j * lda], 1);
- if (ajj <= Zero) {
- A[j + j * lda] = ajj;
- success = 0;
- break;
- }
- ajj = sqrt(ajj);
- A[j + j * lda] = ajj;
-//Compute elements J+1:N of row J.
- if (j < n) {
- Rgemv("Transpose", j, n - j - 1, -One, &A[(j + 1) * lda], lda,
- &A[j * lda], 1, One, &A[j + (j + 1) * lda], lda);
- Rscal(n - j - 1, One / ajj, &A[j + (j + 1) * lda], lda);
- }
- }
- } else {
-//Compute the Cholesky factorization A = L*L'.
- for (j = 0; j < n; j++) {
-// Compute L(J,J) and test for non-positive-definiteness.
- ajj = A[j + j * lda] - Rdot(j, &A[j], lda, &A[j], lda);
- if (ajj <= Zero) {
- A[j + j * lda] = ajj;
- success = 0;
- break;
- }
- ajj = sqrt(ajj);
- A[j + j * lda] = ajj;
-
-//Compute elements J+1:N of column J.
- if (j < n) {
- Rgemv("No transpose", n - j - 1, j, -One, &A[j + 1], lda,
- &A[j], lda, One, &A[j + 1 + j * lda], 1);
- Rscal(n - j - 1, One / ajj, &A[j + 1 + j * lda], 1);
- }
- }
- }
- if (!success)
- *info = j + 1;
- return;
-}
diff --git a/mpack/Rpotrf.cpp b/mpack/Rpotrf.cpp
deleted file mode 100644
index c725ee0..0000000
--- a/mpack/Rpotrf.cpp
+++ /dev/null
@@ -1,156 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rpotrf.cpp,v 1.6 2009/09/22 21:22:09 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rpotrf(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpackint *info)
-{
- mpackint upper;
- mpackint j, jb, nb;
- mpf_class Zero = 0.0, One = 1.0;
-
- *info = 0;
- upper = Mlsame_gmp(uplo, "U");
- if (!upper && !Mlsame_gmp(uplo, "L")) {
- *info = -1;
- } else if (n < 0) {
- *info = -2;
- } else if (lda < max((mpackint)1, n)) {
- *info = -4;
- }
- if (*info != 0) {
- Mxerbla_gmp("Rpotrf", -(*info));
- return;
- }
-//Quick return if possible
- if (n == 0)
- return;
-
-//Determine the block size for this environment.
- nb = iMlaenv_gmp(1, "Rpotrf", uplo, n, -1, -1, -1);
- if (nb <= 1 || nb >= n) {
-//Use unblocked code.
- Rpotf2(uplo, n, A, lda, info);
- } else {
-//Use blocked code.
- if (upper) {
-//Compute the Cholesky factorization A = U'*U.
- for (j = 1; j <= n; j = j + nb) {
-//Update and factorize the current diagonal block and test
-//for non-positive-definiteness.
- jb = min(nb, n - j + 1);
- Rsyrk("Upper", "Transpose", jb, j - 1, -One,
- &A[0 + (j - 1) * lda], lda, One,
- &A[(j - 1) + (j - 1) * lda], lda);
- Rpotf2("Upper", jb, &A[(j - 1) + (j - 1) * lda], lda, info);
- if (*info != 0) {
- goto L30;
- }
- if (j + jb <= n) {
-//Compute the current block row.
- Rgemm("Transpose", "No transpose", jb, n - j - jb + 1,
- j - 1, -One, &A[0 + (j - 1) * lda], lda,
- &A[0 + (j + jb - 1) * lda], lda, One,
- &A[(j - 1) + (j + jb - 1) * lda], lda);
- Rtrsm("Left", "Upper", "Transpose", "Non-unit", jb,
- n - j - jb + 1, One, &A[(j - 1) + (j - 1) * lda], lda,
- &A[(j - 1) + (j + jb - 1) * lda], lda);
- }
- }
- } else {
-//Compute the Cholesky factorization A = L*L'.
- for (j = 1; j <= n; j = j + nb) {
-//Update and factorize the current diagonal block and test
-//for non-positive-definiteness.
- jb = min(nb, n - j + 1);
- Rsyrk("Lower", "No transpose", jb, j - 1, -One, &A[(j - 1) +
- 0 * lda], lda, One, &A[(j - 1) + (j - 1) * lda], lda);
- Rpotf2("Lower", jb, &A[(j - 1) + (j - 1) * lda], lda, info);
- if (*info != 0) {
- goto L30;
- }
- if (j + jb <= n) {
-//Compute the current block column.
- Rgemm("No transpose", "Transpose", n - j - jb + 1, jb,
- j - 1, -One, &A[(j + jb - 1) + 0 * lda], lda,
- &A[(j - 1) + 0 * lda], lda, One,
- &A[(j + jb - 1) + (j - 1) * lda], lda);
- Rtrsm("Right", "Lower", "Transpose", "Non-unit",
- n - j - jb + 1, jb, One, &A[(j - 1) + (j - 1) * lda],
- lda, &A[(j + jb - 1) + (j - 1) * lda], lda);
- }
- }
- }
- }
- return;
-
- L30:
- *info = *info + j - 1;
- return;
-
-}
diff --git a/mpack/Rrot.cpp b/mpack/Rrot.cpp
deleted file mode 100644
index c51e28f..0000000
--- a/mpack/Rrot.cpp
+++ /dev/null
@@ -1,99 +0,0 @@
-/*
- * Copyright (c) 2008-2010
- * Nakata, Maho
- * All rights reserved.
- *
- * $Id: Rrot.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- * SUCH DAMAGE.
- *
- */
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
- *
- * $Id: Rrot.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/drot.f
-applies a plane rotation.
-*/
-
-#include <mblas_gmp.h>
-
-void Rrot(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy, mpackint incy, mpf_class c, mpf_class s)
-{
- mpackint i, ix, iy;
- mpf_class temp;
-
- if (n <= 0)
- return;
- ix = 0;
- iy = 0;
-
- if (incx < 0)
- ix = (-n + 1) * incx;
- if (incy < 0)
- iy = (-n + 1) * incy;
- for (i = 0; i < n; i++) {
- temp = c * dx[ix] + s * dy[iy];
- dy[iy] = c * dy[iy] - s * dx[ix];
- dx[ix] = temp;
- ix = ix + incx;
- iy = iy + incy;
- }
- return;
-}
diff --git a/mpack/Rrotg.cpp b/mpack/Rrotg.cpp
deleted file mode 100644
index b310497..0000000
--- a/mpack/Rrotg.cpp
+++ /dev/null
@@ -1,103 +0,0 @@
-/*
- * Copyright (c) 2008-2010
- * Nakata, Maho
- * All rights reserved.
- *
- * $Id: Rrotg.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- * SUCH DAMAGE.
- *
- */
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
- *
- * $Id: Rrotg.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/drotg.f
-*/
-
-#include <mblas_gmp.h>
-
-void Rrotg(mpf_class * da, mpf_class * db, mpf_class * c, mpf_class * s)
-{
- mpf_class roe, scale;
- mpf_class r, z;
-
- roe = *db;
- if (abs(*da) > abs(*db))
- roe = *da;
- scale = abs(*da) + abs(*db);
- if (scale == 0.0) {
- (*c) = 1.0;
- (*s) = 0.0;
- r = 0.0;
- z = 0.0;
- } else {
- r = scale * sqrt(((*da) / scale) * ((*da) / scale) + ((*db) / scale) * ((*db) / scale));
- r = Msign(1.0, roe) * r;
- (*c) = (*da) / r;
- (*s) = (*db) / r;
- z = 1.0;
- if (abs(*da) > abs(*db))
- z = *s;
- if (abs(*db) >= abs(*da) && *c != 0.0)
- z = 1.0 / (*c);
- }
- *da = r;
- *db = z;
-}
diff --git a/mpack/Rscal.cpp b/mpack/Rscal.cpp
deleted file mode 100644
index 01ba1b4..0000000
--- a/mpack/Rscal.cpp
+++ /dev/null
@@ -1,86 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rscal.cpp,v 1.2 2009/09/12 21:39:52 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-/*
-Based on http://www.netlib.org/blas/dscal.f
-scales a vector by a constant.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rscal(mpackint n, mpf_class da, mpf_class * dx, mpackint incx)
-{
- mpackint nincx;
-
- if (n <= 0 || incx <= 0)
- return;
-
- nincx = n * incx;
- for (mpackint i = 0; i < nincx; i = i + incx) {
- dx[i] = da * dx[i];
- }
- return;
-}
diff --git a/mpack/Rsteqr.cpp b/mpack/Rsteqr.cpp
deleted file mode 100644
index 16fe0f6..0000000
--- a/mpack/Rsteqr.cpp
+++ /dev/null
@@ -1,423 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsteqr.cpp,v 1.9 2009/09/26 02:21:32 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <stdio.h> //for untested part
-void
-Rsteqr(const char *compz, mpackint n, mpf_class * d, mpf_class * e, mpf_class * Z,
- mpackint ldz, mpf_class * work, mpackint *info)
-{
- mpackint nmaxit, maxit, jtot, l1, nm1;
- mpackint i, m, mm, mm1, l, lm1, lend, lsv, lendsv, lendm1, iscale, icompz;
- mpackint lendp1, ii, k, j;
-
- mpf_class Zero = 0.0, One = 1.0, Two = 2.0, Three = 3.0;
- mpf_class eps, eps2, safmin, safmax, ssfmax, ssfmin;
- mpf_class c, s, rt1, rt2;
- mpf_class tst, anorm, po;
- mpf_class f, b, p, g, r;
-
- maxit = 30;
-
- *info = 0;
- if (Mlsame_gmp(compz, "N")) {
- icompz = 0;
- } else if (Mlsame_gmp(compz, "V")) {
- icompz = 1;
- } else if (Mlsame_gmp(compz, "I")) {
- icompz = 2;
- } else {
- icompz = -1;
- }
- if (icompz < 0) {
- *info = -1;
- } else if (n < 0) {
- *info = -2;
- } else if (ldz < 1 || (icompz > 0 && ldz < max((mpackint)1, n)) ) {
- *info = -6;
- }
- if (*info != 0) {
- Mxerbla_gmp("Rsteqr", -(*info));
- return;
- }
-//Quick return if possible
- if (n == 0)
- return;
- if (n == 1) {
- if (icompz == 2) {
- Z[0] = One;
- }
- return;
- }
-//Determine the unit roundoff and over/underflow thresholds.
- eps = Rlamch_gmp("E");
- eps2 = eps * eps;
- safmin = Rlamch_gmp("S");
- safmax = One / safmin;
- ssfmax = sqrt(safmax) / Three;
- ssfmin = sqrt(safmin) / eps2;
-//Compute the eigenvalues and eigenvectors of the tridiagonal
-//matrix.
- if (icompz == 2)
- Rlaset("Full", n, n, Zero, One, Z, ldz);
-
- nmaxit = n * 30;
- jtot = 0;
-//Determine where the matrix splits and choose QL or QR iteration
-//for each block, according to whether top or bottom diagonal
-//element is smaller.
- l1 = 1;
- nm1 = n - 1;
-
- L10:
- if (l1 > n) {
- goto L160;
- }
- if (l1 > 1) {
- e[l1 - 2] = Zero;
- }
- if (l1 <= nm1) {
- for (m = l1; m <= nm1; m++) {
- tst = abs(e[m - 1]);
- if (tst == Zero) {
- goto L30;
- }
- if (tst <= sqrt(abs(d[m - 1])) * sqrt(abs(d[m])) * eps) {
- e[m - 1] = Zero;
- goto L30;
- }
- }
- }
- m = n;
-
- L30:
- l = l1;
- lsv = l;
- lend = m;
- lendsv = lend;
- l1 = m + 1;
- if (lend == l) {
- goto L10;
- }
-//Scale submatrix in rows and columns L to LEND
- anorm = Rlanst("I", lend - l + 1, &d[l - 1], &e[l - 1]);
- iscale = 0;
- if (anorm == Zero) {
- goto L10;
- }
- if (anorm > ssfmax) {
- iscale = 1;
- printf("XXX Rsteqr not tested 1\n");
- Rlascl("G", 0, 0, anorm, ssfmax, lend - l + 1, 1, &d[l - 1], n, info);
- Rlascl("G", 0, 0, anorm, ssfmax, lend - l, 1, &e[l - 1], n, info);
- } else if (anorm < ssfmin) {
- iscale = 2;
- printf("XXX Rsteqr not tested 2\n");
- Rlascl("G", 0, 0, anorm, ssfmin, lend - l + 1, 1, &d[l - 1], n, info);
- Rlascl("G", 0, 0, anorm, ssfmin, lend - l, 1, &e[l - 1], n, info);
- }
-//Choose between QL and QR iteration
- if (abs(d[lend - 1]) < abs(d[l - 1])) {
- lend = lsv;
- l = lendsv;
- }
- if (lend > l) {
-//QL Iteration
-//Look for small subdiagonal element.
- L40:
- if (l != lend) {
- lendm1 = lend - 1;
- for (m = l; m <= lendm1; m++) {
- tst = abs(e[m - 1]) * abs(e[m - 1]);
- if (tst <= eps2 * abs(d[m - 1]) * abs(d[m]) + safmin) {
- goto L60;
- }
- }
- }
- m = lend;
- L60:
- if (m < lend) {
- e[m - 1] = Zero;
- }
- p = d[l - 1];
- if (m == l) {
- goto L80;
- }
-//If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
-//to compute its eigensystem.
- if (m == l + 1) {
- if (icompz > 0) {
- Rlaev2(d[l - 1], e[l - 1], d[l], &rt1, &rt2, &c, &s);
- work[l - 1] = c;
- work[n - 1 + l - 1] = s;
- Rlasr("R", "V", "B", n, 2, &work[l - 1], &work[n + l - 2],
- &Z[0 + (l - 1) * ldz], ldz);
- } else {
- Rlae2(d[l - 1], e[l - 1], d[l], &rt1, &rt2);
- }
- d[l - 1] = rt1;
- d[l] = rt2;
- e[l - 1] = Zero;
- l = l + 2;
- if (l <= lend) {
- goto L40;
- }
- goto L140;
- }
- if (jtot == nmaxit) {
- goto L140;
- }
- jtot++;
-//Form shift.
- g = (d[l] - p) / (e[l - 1] * Two);
- r = Rlapy2(g, One);
- g = d[m - 1] - p + e[l - 1] / (g + Msign(r, g));
-
- s = One;
- c = One;
- p = Zero;
-//Inner loop
- mm1 = m - 1;
- for (i = mm1; i >= l; i--) {
- f = s * e[i - 1];
- b = c * e[i - 1];
- Rlartg(g, f, &c, &s, &r);
- if (i != m - 1) {
- e[i] = r;
- }
- g = d[i] - p;
- r = (d[i - 1] - g) * s + c * Two * b;
- p = s * r;
- d[i] = g + p;
- g = c * r - b;
-//If eigenvectors are desired, then save rotations.
- if (icompz > 0) {
- work[i - 1] = c;
- work[n - 2 + i] = -s;
- }
- }
-//If eigenvectors are desired, then apply saved rotations.
- if (icompz > 0) {
- mm = m - l + 1;
- Rlasr("R", "V", "B", n, mm, &work[l - 1], &work[n - 2 + l],
- &Z[0 + (l - 1) * ldz], ldz);
- }
- d[l - 1] = d[l - 1] - p;
- e[l - 1] = g;
- goto L40;
-//Eigenvalue found.
- L80:
- d[l - 1] = p;
-
- l++;
- if (l <= lend) {
- goto L40;
- }
- goto L140;
- } else {
-//QR Iteration
-//Look for small superdiagonal element.
- L90:
- if (l != lend) {
- lendp1 = lend + 1;
- for (m = l; m >= lendp1; m--) {
- tst = abs(e[m - 2]) * abs(e[m - 2]);
- if (tst <= eps2 * abs(d[m - 1]) * abs(d[m - 2]) + safmin) {
- goto L110;
- }
- }
- }
- m = lend;
- L110:
- if (m > lend) {
- e[m - 2] = Zero;
- }
- p = d[l - 1];
- if (m == l) {
- goto L130;
- }
-//If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
-//to compute its eigensystem.
- if (m == l - 1) {
- if (icompz > 0) {
- Rlaev2(d[l - 2], e[l - 2], d[l - 1], &rt1, &rt2, &c, &s);
- work[m - 1] = c;
- work[n - 2 + m] = s;
- Rlasr("R", "V", "F", n, 2, &work[m - 1], &work[n - 2 + m],
- &Z[0 + (l - 2) * ldz], ldz);
- } else {
- Rlae2(d[l - 2], e[l - 2], d[l - 1], &rt1, &rt2);
- }
- d[l - 2] = rt1;
- d[l - 1] = rt2;
- e[l - 2] = Zero;
- l = l - 2;
- if (l >= lend) {
- goto L90;
- }
- goto L140;
- }
- if (jtot == nmaxit) {
- goto L140;
- }
- jtot++;
-//Form shift.
- g = (d[l - 2] - p) / (e[l - 2] * Two);
- r = Rlapy2(g, One);
- g = d[m - 1] - p + e[l - 2] / (g + Msign(r, g));
- s = One;
- c = One;
- p = Zero;
-//Inner loop
- lm1 = l - 1;
- for (i = m; i <= lm1; i++) {
- f = s * e[i - 1];
- b = c * e[i - 1];
- Rlartg(g, f, &c, &s, &r);
- if (i != m) {
- e[i - 2] = r;
- }
- g = d[i - 1] - p;
- r = (d[i] - g) * s + c * Two * b;
- p = s * r;
- d[i - 1] = g + p;
- g = c * r - b;
-//If eigenvectors are desired, then save rotations.
- if (icompz > 0) {
- work[i - 1] = c;
- work[n - 2 + i] = s;
- }
- }
-//If eigenvectors are desired, then apply saved rotations.
- if (icompz > 0) {
- mm = l - m + 1;
- Rlasr("R", "V", "F", n, mm, &work[m - 1], &work[n - 2 + m],
- &Z[0 + (m - 1) * ldz], ldz);
- }
- d[l - 1] = d[l - 1] - p;
- e[lm1 - 1] = g;
- goto L90;
-//Eigenvalue found.
- L130:
- d[l - 1] = p;
- l--;
- if (l >= lend) {
- goto L90;
- }
- goto L140;
- }
-//Undo scaling if necessary
- L140:
- if (iscale == 1) {
- Rlascl("G", 0, 0, ssfmax, anorm, lendsv - lsv + 1, 1, &d[lsv - 1], n,
- info);
- Rlascl("G", 0, 0, ssfmax, anorm, lendsv - lsv, 1, &e[lsv - 1], n,
- info);
- } else if (iscale == 2) {
- Rlascl("G", 0, 0, ssfmin, anorm, lendsv - lsv + 1, 1, &d[lsv - 1], n,
- info);
- Rlascl("G", 0, 0, ssfmin, anorm, lendsv - lsv, 1, &e[lsv - 1], n,
- info);
- }
-//Check for no convergence to an eigenvalue after a total
-//of N*MAXIT iterations.
- if (jtot < nmaxit) {
- goto L10;
- }
- for (i = 1; i <= n - 1; i++) {
- if (e[i] != Zero) {
- ++(*info);
- }
- }
- goto L190;
-//Order eigenvalues and eigenvectors.
- L160:
- if (icompz == 0) {
-//Use Quick Sort
- Rlasrt("I", n, d, info);
- } else {
-//Use Selection Sort to minimize swaps of eigenvectors
- for (ii = 2; ii <= n; ii++) {
- i = ii - 1;
- k = i;
- p = d[i - 1];
- for (j = ii; j <= n; j++) {
- if (d[j - 1] < p) {
- k = j;
- p = d[j - 1];
- }
- }
- if (k != i) {
- d[k - 1] = d[i - 1];
- d[i - 1] = p;
- Rswap(n, &Z[0 + (i - 1) * ldz], 1, &Z[0 + (k - 1) * ldz], 1);
- }
- }
- }
- L190:
- return;
-}
diff --git a/mpack/Rsterf.cpp b/mpack/Rsterf.cpp
deleted file mode 100644
index cf1e633..0000000
--- a/mpack/Rsterf.cpp
+++ /dev/null
@@ -1,339 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsterf.cpp,v 1.8 2009/09/26 02:21:32 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <stdio.h> //for untested part
-void
-Rsterf(mpackint n, mpf_class * d, mpf_class * e, mpackint *info)
-{
- mpf_class Zero = 0.0, One = 1.0, Two = 2.0, Three = 3.0;
- mpf_class sigma;
- mpf_class eps, eps2;
- mpf_class safmin, safmax, ssfmax, ssfmin, anorm;
- mpf_class rte, rt1, rt2, s, c, r, oldc, oldgam, gamma, p, bb, alpha;
-
- mpackint nmaxit;
- mpackint iscale;
- mpackint l1, jtot;
- mpackint i, l, m;
- mpackint lsv, lend, lendsv;
-
- *info = 0;
-//Quick return if possible
- if (n < 0) {
- *info = -1;
- Mxerbla_gmp("Rsterf", -(*info));
- return;
- }
- if (n <= 1)
- return;
-//Determine the unit roundoff for this environment.
- eps = Rlamch_gmp("E");
- eps2 = eps * eps;
- safmin = Rlamch_gmp("S");
- safmax = One / safmin;
- ssfmax = sqrt(safmax) / Three;
- ssfmin = sqrt(safmin) / eps2;
-//Compute the eigenvalues of the tridiagonal matrix.
- nmaxit = n * 30;
- sigma = Zero;
- jtot = 0;
-//Determine where the matrix splits and choose QL or QR iteration
-//for each block, according to whether top or bottom diagonal
-//element is smaller.
- l1 = 1;
- L10:
- if (l1 > n) {
- goto L170;
- }
- if (l1 > 1) {
- e[l1 - 2] = Zero;
- }
- for (m = l1; m <= n - 1; m++) {
- if (abs(e[m - 1]) <= sqrt(abs(d[m - 1])) * sqrt(abs(d[m])) * eps) {
- e[m - 1] = Zero;
- goto L30;
- }
- }
- m = n;
- L30:
- l = l1;
- lsv = l;
- lend = m;
- lendsv = lend;
- l1 = m + 1;
- if (lend == l) {
- goto L10;
- }
-//Scale submatrix in rows and columns L to LEND
- anorm = Rlanst("I", lend - l + 1, &d[l - 1], &e[l - 1]);
- iscale = 0;
- if (anorm > ssfmax) {
- printf("XXX not tested #1\n");
- iscale = 1;
- Rlascl("G", 0, 0, anorm, ssfmax, lend - l + 1, 1, &d[l - 1], n, info);
- Rlascl("G", 0, 0, anorm, ssfmax, lend - l, 1, &e[l - 1], n, info);
- } else if (anorm < ssfmin) {
- printf("XXX not tested #2\n");
- iscale = 2;
- Rlascl("G", 0, 0, anorm, ssfmin, lend - l + 1, 1, &d[l - 1], n, info);
- Rlascl("G", 0, 0, anorm, ssfmin, lend - l, 1, &e[l - 1], n, info);
- }
- for (i = l; i <= lend - 1; i++) {
- e[i - 1] = e[i - 1] * e[i - 1];
- }
-//Choose between QL and QR iteration
- if (abs(d[lend - 1]) < abs(d[l - 1])) {
- lend = lsv;
- l = lendsv;
- }
- if (lend >= l) {
-//QL Iteration
-//Look for small subdiagonal element.
- L50:
- if (l != lend) {
- for (m = l; m <= lend - 1; m++) {
- if (abs(e[m - 1]) <= eps2 * abs(d[m - 1] * d[m])) {
- goto L70;
- }
- }
- }
- m = lend;
- L70:
- if (m < lend) {
- e[m - 1] = Zero;
- }
- p = d[l - 1];
- if (m == l) {
- goto L90;
- }
-//If remaining matrix is 2 by 2, use DLAE2 to compute its
-//eigenvalues.
- if (m == l + 1) {
- rte = sqrt(e[l - 1]);
- Rlae2(d[l - 1], rte, d[l], &rt1, &rt2);
- d[l - 1] = rt1;
- d[l] = rt2;
- e[l - 1] = Zero;
- l = l + 2;
- if (l <= lend) {
- goto L50;
- }
- goto L150;
- }
- if (jtot == nmaxit) {
- goto L150;
- }
- jtot++;
-//Form shift.
- rte = sqrt(e[l - 1]);
- sigma = (d[l] - p) / (rte * Two);
- r = Rlapy2(sigma, One);
- sigma = p - rte / (sigma + Msign(r, sigma));
- c = One;
- s = Zero;
- gamma = d[m - 1] - sigma;
- p = gamma * gamma;
-//Inner loop
- for (i = m - 1; i >= l; i--) {
- bb = e[i - 1];
- r = p + bb;
- if (i != m - 1) {
- e[i] = s * r;
- }
- oldc = c;
- c = p / r;
- s = bb / r;
- oldgam = gamma;
- alpha = d[i - 1];
- gamma = c * (alpha - sigma) - s * oldgam;
- d[i] = oldgam + (alpha - gamma);
- if (c != Zero) {
- p = gamma * gamma / c;
- } else {
- p = oldc * bb;
- }
- }
- e[l - 1] = s * p;
- d[l - 1] = sigma + gamma;
- goto L50;
-//Eigenvalue found.
- L90:
- d[l - 1] = p;
- l++;
- if (l <= lend) {
- goto L50;
- }
- goto L150;
- } else {
-//QR Iteration
-//Look for small superdiagonal element.
- L100:
- for (m = l; m >= lend + 1; m--) {
- if (abs(e[m - 2]) <= eps2 * abs(d[m - 1] * d[m - 2])) {
- goto L120;
- }
- }
- m = lend;
- L120:
- if (m > lend) {
- e[m - 2] = Zero;
- }
- p = d[l - 1];
- if (m == l) {
- goto L140;
- }
-//If remaining matrix is 2 by 2, use DLAE2 to compute its
-//eigenvalues.
- if (m == l - 1) {
- rte = sqrt(e[l - 2]);
- Rlae2(d[l - 1], rte, d[l - 2], &rt1, &rt2);
- d[l - 1] = rt1;
- d[l - 2] = rt2;
- e[l - 2] = Zero;
- l = l - 2;
- if (l >= lend) {
- goto L100;
- }
- goto L150;
- }
-
- if (jtot == nmaxit) {
- goto L150;
- }
- jtot++;
-//Form shift.
- rte = sqrt(e[l - 2]);
- sigma = (d[l - 2] - p) / (rte * Two);
- r = Rlapy2(sigma, One);
- sigma = p - rte / (sigma + Msign(r, sigma));
-
- c = One;
- s = Zero;
- gamma = d[m - 1] - sigma;
- p = gamma * gamma;
-//Inner loop
- for (i = m; i <= l - 1; i++) {
- bb = e[i - 1];
- r = p + bb;
- if (i != m) {
- e[i - 2] = s * r;
- }
- oldc = c;
- c = p / r;
- s = bb / r;
- oldgam = gamma;
- alpha = d[i];
- gamma = c * (alpha - sigma) - s * oldgam;
- d[i - 1] = oldgam + (alpha - gamma);
- if (c != Zero) {
- p = gamma * gamma / c;
- } else {
- p = oldc * bb;
- }
- }
-
- e[l - 2] = s * p;
- d[l - 1] = sigma + gamma;
- goto L100;
-//Eigenvalue found.
- L140:
- d[l - 1] = p;
-
- l--;
- if (l >= lend) {
- goto L100;
- }
- goto L150;
- }
-//Undo scaling if necessary
- L150:
- if (iscale == 1) {
- Rlascl("G", 0, 0, ssfmax, anorm, lendsv - lsv + 1, 1, &d[lsv - 1], n,
- info);
- }
- if (iscale == 2) {
- Rlascl("G", 0, 0, ssfmin, anorm, lendsv - lsv + 1, 1, &d[lsv - 1], n,
- info);
- }
-//Check for no convergence to an eigenvalue after a total
-//of N*MAXIT iterations.
- if (jtot < nmaxit) {
- goto L10;
- }
- for (i = 1; i <= n - 1; i++) {
- if (e[i - 1] != Zero) {
- ++(*info);
- }
- }
- return;
-
-//Sort eigenvalues in increasing order.
- L170:
- Rlasrt("I", n, &d[0], info);
- return;
-}
diff --git a/mpack/Rswap.cpp b/mpack/Rswap.cpp
deleted file mode 100644
index 25c4b72..0000000
--- a/mpack/Rswap.cpp
+++ /dev/null
@@ -1,98 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rswap.cpp,v 1.2 2009/09/12 21:39:52 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dswap.f
-mpackinterchanges two vectors.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rswap(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy, mpackint incy)
-{
- mpackint ix, iy;
-
- mpf_class temp;
-
- if (n <= 0)
- return;
- ix = 0;
- iy = 0;
-
- if (incx < 0)
- ix = (-n + 1) * incx;
- if (incy < 0)
- iy = (-n + 1) * incy;
- for (mpackint i = 0; i < n; i++) {
- temp = dx[ix];
- dx[ix] = dy[iy];
- dy[iy] = temp;
- ix = ix + incx;
- iy = iy + incy;
- }
- return;
-}
diff --git a/mpack/Rsyev.cpp b/mpack/Rsyev.cpp
deleted file mode 100644
index 81311e8..0000000
--- a/mpack/Rsyev.cpp
+++ /dev/null
@@ -1,180 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsyev.cpp,v 1.7 2009/09/22 21:22:09 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rsyev(const char *jobz, const char *uplo, mpackint n, mpf_class * A,
- mpackint lda, mpf_class * w, mpf_class * work, mpackint *lwork, mpackint *info)
-{
-
- mpackint wantz, lower, lquery, nb, lwkopt, iscale, imax;
- mpackint inde, indtau, indwrk, llwork, iinfo;
-
- mpf_class Zero = 0.0, One = 1.0, Two = 2.0;
- mpf_class safmin, eps, smlnum, bignum, rmin, rmax;
- mpf_class sigma, anrm;
- mpf_class rtmp;
-
- wantz = Mlsame_gmp(jobz, "V");
- lower = Mlsame_gmp(uplo, "L");
- lquery = 0;
- if (*lwork == -1)
- lquery = 1;
-
- *info = 0;
- if (!(wantz || Mlsame_gmp(jobz, "N"))) {
- *info = -1;
- } else if (!(lower || Mlsame_gmp(uplo, "U"))) {
- *info = -2;
- } else if (n < 0) {
- *info = -3;
- } else if (lda < max((mpackint)1, n)) {
- *info = -5;
- }
-
- if (*info == 0) {
- nb = iMlaenv_gmp(1, "Rsytrd", uplo, n, -1, -1, -1);
- lwkopt = max((mpackint)1, (nb + 2) * n);
- work[0] = (double)lwkopt; //needs cast mpackint to mpf
- if (*lwork < max((mpackint)1, 3 * n - 1) && !lquery) {
- *info = -8;
- }
- }
-
- if (*info != 0) {
- Mxerbla_gmp("Rsyev ", -(*info));
- return;
- } else if (lquery) {
- return;
- }
-//Quick return if possible
- if (n == 0) {
- return;
- }
- if (n == 1) {
- w[0] = A[0];
- work[0] = Two;
- if (wantz) {
- A[0] = One;
- }
- return;
- }
-//Get machine constants.
- safmin = Rlamch_gmp("Safe minimum");
- eps = Rlamch_gmp("Precision");
- smlnum = safmin / eps;
- bignum = One / smlnum;
- rmin = sqrt(smlnum);
- rmax = sqrt(bignum);
-
-//Scale matrix to allowable range, if necessary.
- anrm = Rlansy("M", uplo, n, A, lda, work);
- iscale = 0;
- if (anrm > Zero && anrm < rmin) {
- iscale = 1;
- sigma = rmin / anrm;
- } else if (anrm > rmax) {
- iscale = 1;
- sigma = rmax / anrm;
- }
- if (iscale == 1) {
- Rlascl(uplo, 0, 0, One, sigma, n, n, A, lda, info);
- }
-//Call DSYTRD to reduce symmetric matrix to tridiagonal form.
- inde = 1;
- indtau = inde + n;
- indwrk = indtau + n;
- llwork = *lwork - indwrk + 1;
- Rsytrd(uplo, n, &A[0], lda, &w[0], &work[inde - 1], &work[indtau - 1],
- &work[indwrk - 1], llwork, &iinfo);
-
-//For eigenvalues only, call DSTERF. For eigenvectors, first call
-//DORGTR to generate the orthogonal matrix, then call DSTEQR.
- if (!wantz) {
- Rsterf(n, &w[0], &work[inde - 1], info);
- } else {
- Rorgtr(uplo, n, A, lda, &work[indtau - 1], &work[indwrk - 1], llwork,
- &iinfo);
- Rsteqr(jobz, n, w, &work[inde - 1], A, lda, &work[indtau - 1], info);
- }
-
-//If matrix was scaled, then rescale eigenvalues appropriately.
- if (iscale == 1) {
- if (*info == 0) {
- imax = n;
- } else {
- imax = *info - 1;
- }
- rtmp = One / sigma;
- Rscal(imax, rtmp, &w[0], 1);
- }
-//Set WORK(1) to optimal workspace size.
- work[0] = (double)lwkopt; //needs cast from mpackint to mpf
-
- return;
-}
diff --git a/mpack/Rsymv.cpp b/mpack/Rsymv.cpp
deleted file mode 100644
index a45467e..0000000
--- a/mpack/Rsymv.cpp
+++ /dev/null
@@ -1,183 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsymv.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dsymv.f
-Rsymv 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.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rsymv(const char *uplo, mpackint n, mpf_class alpha, mpf_class * A,
- mpackint lda, mpf_class * x, mpackint incx, mpf_class beta, mpf_class * y,
- mpackint incy)
-{
- mpackint ix, iy, jx, jy, kx, ky;
-
- mpf_class Zero = 0.0, One = 1.0;
-
- mpf_class temp1, temp2;
-
- //test the input parameters.
- mpackint info = 0;
-
- if (!Mlsame_gmp(uplo, "U") && !Mlsame_gmp(uplo, "L"))
- info = 1;
- else if (n < 0)
- info = 2;
- else if (lda < max((mpackint) 1, n))
- info = 5;
- else if (incx == 0)
- info = 7;
- else if (incy == 0)
- info = 10;
-
- if (info != 0) {
- Mxerbla_gmp("Rsymv ", info);
- return;
- }
- //quick return if possible.
- if ((n == 0) || ((alpha == Zero) && (beta == One)))
- return;
-
- //set up the start points in x and y.
- if (incx > 0)
- kx = 0;
- else
- kx = -(n - 1) * incx;
- if (incy > 0)
- ky = 0;
- else
- ky = -(n - 1) * incy;
-
- //start the operations. in this version the elements of a are
- //accessed sequentially with one pass through the triangular part
- //of A.
-
- //first form y := beta*y.
- if (beta != One) {
- iy = ky;
- if (beta == Zero) {
- for (mpackint i = 0; i < n; i++) {
- y[iy] = Zero;
- iy = iy + incy;
- }
- } else {
- for (mpackint i = 0; i < n; i++) {
- y[iy] = beta * y[iy];
- iy = iy + incy;
- }
- }
- }
- if (alpha == Zero)
- return;
-
- if (Mlsame_gmp(uplo, "U")) {
- //form y when a is stored in upper triangle.
- jx = kx;
- jy = ky;
- for (mpackint j = 0; j < n; j++) {
- temp1 = alpha * x[jx];
- temp2 = Zero;
- ix = kx;
- iy = ky;
- for (mpackint i = 0; i < j; i++) {
- y[iy] = y[iy] + temp1 * A[i + j * lda];
- temp2 = temp2 + A[i + j * lda] * x[ix];
- ix = ix + incx;
- iy = iy + incy;
- }
- y[jy] = y[jy] + temp1 * A[j + j * lda] + alpha * temp2;
- jx = jx + incx;
- jy = jy + incy;
- }
- } else {
- //form y when a is stored in lower triangle.
- jx = kx;
- jy = ky;
- for (mpackint j = 0; j < n; j++) {
- temp1 = alpha * x[jx];
- temp2 = Zero;
- y[jy] = y[jy] + temp1 * A[j + j * lda];
- ix = jx;
- iy = jy;
- for (mpackint i = j + 1; i < n; i++) {
- ix = ix + incx;
- iy = iy + incy;
- y[iy] = y[iy] + temp1 * A[i + j * lda];
- temp2 = temp2 + A[i + j * lda] * x[ix];
- }
- y[jy] = y[jy] + alpha * temp2;
- jx = jx + incx;
- jy = jy + incy;
- }
- }
- return;
-}
diff --git a/mpack/Rsyr2.cpp b/mpack/Rsyr2.cpp
deleted file mode 100644
index e3fbb48..0000000
--- a/mpack/Rsyr2.cpp
+++ /dev/null
@@ -1,156 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsyr2.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dsyr2.f
-Rsyr2 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.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rsyr2(const char *uplo, mpackint n, mpf_class alpha, mpf_class * x,
- mpackint incx, mpf_class * y, mpackint incy, mpf_class * A, mpackint lda)
-{
- mpf_class temp1, temp2;
-
- mpf_class Zero = 0.0;
-
- mpackint ix, iy, jx, jy, kx, ky;
-
- //test the input parameters.
- mpackint info = 0;
-
- if (!Mlsame_gmp(uplo, "U") && !Mlsame_gmp(uplo, "L"))
- info = 1;
- else if (n < 0)
- info = 2;
- else if (incx == 0)
- info = 5;
- else if (incy == 0)
- info = 7;
- else if (lda < max((mpackint) 1, n))
- info = 9;
- if (info != 0) {
- Mxerbla_gmp("Rsyr2 ", info);
- return;
- }
- //quick return if possible.
- if ((n == 0) || (alpha == Zero))
- return;
-
- if (incx > 0)
- kx = 0;
- else
- kx = -(n - 1) * incx;
- if (incy > 0)
- ky = 0;
- else
- ky = -(n - 1) * incy;
- jx = kx;
- jy = ky;
-
- if (Mlsame_gmp(uplo, "U")) {
- for (mpackint j = 0; j < n; j++) {
- if ((x[jx] != Zero) || (y[jy] != Zero)) {
- temp1 = alpha * y[jy];
- temp2 = alpha * x[jx];
- ix = kx;
- iy = ky;
- for (mpackint i = 0; i <= j; i++) {
- A[i + j * lda] =
- A[i + j * lda] + x[ix] * temp1 + y[iy] * temp2;
- ix = ix + incx;
- iy = iy + incy;
- }
- }
- jx = jx + incx;
- jy = jy + incy;
- }
- } else {
- //form a when a is stored in the lower triangle.
- for (mpackint j = 0; j < n; j++) {
- if ((x[jx] != Zero) || (y[jy] != Zero)) {
- temp1 = alpha * y[jy];
- temp2 = alpha * x[jx];
- ix = jx;
- iy = jy;
- for (mpackint i = j; i < n; i++) {
- A[i + j * lda] =
- A[i + j * lda] + x[ix] * temp1 + y[iy] * temp2;
- ix = ix + incx;
- iy = iy + incy;
- }
- }
- jx = jx + incx;
- jy = jy + incy;
- }
- }
- return;
-}
diff --git a/mpack/Rsyr2k.cpp b/mpack/Rsyr2k.cpp
deleted file mode 100644
index af4c5b4..0000000
--- a/mpack/Rsyr2k.cpp
+++ /dev/null
@@ -1,246 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsyr2k.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-http://www.netlib.org/blas/dsyr2k.f
-Rsyr2k performs one of the symmetric rank 2k operations
-C := alpha*A*B' + alpha*B*A' + beta*C,
- or
-C := alpha*A'*B + alpha*B'*A + beta*C,
-where alpha and beta are scalars, C is an n by n symmetric matrix
-and A and B are n by k matrices in the first case and k by n
-matrices in the second case.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rsyr2k(const char *uplo, const char *trans, mpackint n, mpackint k,
- mpf_class alpha, mpf_class * A, mpackint lda, mpf_class * B, mpackint ldb,
- mpf_class beta, mpf_class * C, mpackint ldc)
-{
- mpackint nrowa, upper, info;
-
- mpf_class Zero = 0.0, One = 1.0;
-
- mpf_class temp1, temp2;
-
- //test the input parameters.
- if (Mlsame_gmp(trans, "N"))
- nrowa = n;
- else
- nrowa = k;
- upper = Mlsame_gmp(uplo, "U");
-
- info = 0;
- if ((!upper) && (!Mlsame_gmp(uplo, "L")))
- info = 1;
- else if ((!Mlsame_gmp(trans, "N")) && (!Mlsame_gmp(trans, "T"))
- && (!Mlsame_gmp(trans, "C")))
- info = 2;
- else if (n < 0)
- info = 3;
- else if (k < 0)
- info = 4;
- else if (lda < max((mpackint) 1, nrowa))
- info = 7;
- else if (ldb < max((mpackint) 1, nrowa))
- info = 9;
- else if (ldc < max((mpackint) 1, n))
- info = 12;
- if (info != 0) {
- Mxerbla_gmp("Rsyr2k", info);
- return;
- }
- //quick return if possible.
- if ((n == 0) || (((alpha == Zero) || (k == 0)) && (beta == One)))
- return;
-
- //and when alpha==Zero.
- if (alpha == Zero) {
- if (upper) {
- if (beta == Zero) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] = Zero;
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- }
- } else {
- if (beta == Zero) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] = Zero;
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- }
- }
- return;
- }
- //start the operations.
- if (Mlsame_gmp(trans, "N")) {
- //form C:= alpha*A*B' + alpha*B*A'+C.
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- if (beta == Zero) {
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] = Zero;
- }
- } else if (beta != One) {
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- for (mpackint l = 0; l < k; l++) {
- if ((A[j + l * lda] != Zero) || (B[j + l * ldb] != Zero)) {
- temp1 = alpha * B[j + l * ldb];
- temp2 = alpha * A[j + l * lda];
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] =
- C[i + j * ldc] + A[i + l * lda] * temp1 + B[i +
- l * ldb] * temp2;
- }
- }
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- if (beta == Zero) {
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] = Zero;
- }
- } else if (beta != One) {
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- for (mpackint l = 0; l < k; l++) {
- if ((A[j + l * lda] != Zero) || (B[j + l * ldb] != Zero)) {
- temp1 = alpha * B[j + l * ldb];
- temp2 = alpha * A[j + l * lda];
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] =
- C[i + j * ldc] + A[i + l * lda] * temp1 + B[i +
- l * ldb] * temp2;
- }
- }
- }
- }
- }
- } else {
- //form C := alpha*A'*B + alpha*B'*A + C.
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i <= j; i++) {
- temp1 = Zero;
- temp2 = Zero;
- for (mpackint l = 0; l < k; l++) {
- temp1 = temp1 + A[l + i * lda] * B[l + j * ldb];
- temp2 = temp2 + B[l + i * ldb] * A[l + j * lda];
- }
- if (beta == Zero) {
- C[i + j * ldc] = alpha * temp1 + alpha * temp2;
- } else {
- C[i + j * ldc] =
- beta * C[i + j * ldc] + alpha * temp1 +
- alpha * temp2;
- }
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = j; i < n; i++) {
- temp1 = Zero;
- temp2 = Zero;
- for (mpackint l = 0; l < k; l++) {
- temp1 = temp1 + A[l + i * lda] * B[l + j * ldb];
- temp2 = temp2 + B[l + i * ldb] * A[l + j * lda];
- }
- if (beta == Zero) {
- C[i + j * ldc] = alpha * temp1 + alpha * temp2;
- } else {
- C[i + j * ldc] =
- beta * C[i + j * ldc] + alpha * temp1 +
- alpha * temp2;
- }
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rsyrk.cpp b/mpack/Rsyrk.cpp
deleted file mode 100644
index 5ada114..0000000
--- a/mpack/Rsyrk.cpp
+++ /dev/null
@@ -1,230 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsyrk.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Rsyrk performs one of the symmetric rank k operations
- C := alpha*A*A' + beta*C,
-or
- C := alpha*A'*A + beta*C,
-where alpha and beta are scalars, C is an n by n symmetric matrix
-and A is an n by k matrix in the first case and a k by n matrix
-in the second case.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rsyrk(const char *uplo, const char *trans, mpackint n, mpackint k,
- mpf_class alpha, mpf_class * A, mpackint lda, mpf_class beta,
- mpf_class * C, mpackint ldc)
-{
- mpackint nrowa, upper, info;
-
- mpf_class Zero = 0.0, One = 1.0;
-
- mpf_class temp;
-
- //Test the input parameters.
- if (Mlsame_gmp(trans, "N"))
- nrowa = n;
- else
- nrowa = k;
- upper = Mlsame_gmp(uplo, "U");
-
- info = 0;
- if ((!upper) && (!Mlsame_gmp(uplo, "L")))
- info = 1;
- else if ((!Mlsame_gmp(trans, "N")) && (!Mlsame_gmp(trans, "T"))
- && (!Mlsame_gmp(trans, "C")))
- info = 2;
- else if (n < 0)
- info = 3;
- else if (k < 0)
- info = 4;
- else if (lda < max((mpackint) 1, nrowa))
- info = 7;
- else if (ldc < max((mpackint) 1, n))
- info = 10;
- if (info != 0) {
- Mxerbla_gmp("Rsyrk ", info);
- return;
- }
- //quick return if possible.
- if ((n == 0) || (((alpha == Zero) || (k == 0)) && (beta == One)))
- return;
-
- //and when alpha==Zero.
- if (alpha == Zero) {
- if (upper) {
- if (beta == Zero) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] = Zero;
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- }
- } else {
- if (beta == Zero) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] = Zero;
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- }
- }
- return;
- }
- //start the operations.
- if (Mlsame_gmp(trans, "N")) {
- //Form C := alpha*A*A' + beta*C.
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- if (beta == Zero) {
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] = Zero;
- }
- } else if (beta != One) {
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- for (mpackint l = 0; l < k; l++) {
- if (A[j + l * lda] != Zero) {
- temp = alpha * A[j + l * lda];
- for (mpackint i = 0; i <= j; i++) {
- C[i + j * ldc] =
- C[i + j * ldc] + temp * A[i + l * lda];
- }
- }
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- if (beta == Zero) {
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] = Zero;
- }
- } else if (beta != One) {
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] = beta * C[i + j * ldc];
- }
- }
- for (mpackint l = 0; l < k; l++) {
- if (A[j + l * lda] != Zero) {
- temp = alpha * A[j + l * lda];
- for (mpackint i = j; i < n; i++) {
- C[i + j * ldc] =
- C[i + j * ldc] + temp * A[i + l * lda];
- }
- }
- }
- }
- }
- } else {
- //Form C := alpha*A'*A + beta*C.
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i <= j; i++) {
- temp = Zero;
- for (mpackint l = 0; l < k; l++) {
- temp = temp + A[l + i * lda] * A[l + j * lda];
- }
- if (beta == Zero) {
- C[i + j * ldc] = alpha * temp;
- } else {
- C[i + j * ldc] = alpha * temp + beta * C[i + j * ldc];
- }
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = j; i < n; i++) {
- temp = Zero;
- for (mpackint l = 0; l < k; l++) {
- temp = temp + A[l + i * lda] * A[l + j * lda];
- }
- if (beta == Zero)
- C[i + j * ldc] = alpha * temp;
- else
- C[i + j * ldc] = alpha * temp + beta * C[i + j * ldc];
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rsytd2.cpp b/mpack/Rsytd2.cpp
deleted file mode 100644
index c0b7160..0000000
--- a/mpack/Rsytd2.cpp
+++ /dev/null
@@ -1,151 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsytd2.cpp,v 1.6 2009/09/22 21:28:58 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rsytd2(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpf_class * d,
- mpf_class * e, mpf_class * tau, mpackint *info)
-{
-
- mpf_class One = 1.0, Zero = 0.0, Half = 0.5;
- mpf_class taui, alpha;
- mpackint upper;
- mpackint i;
-
- *info = 0;
- upper = Mlsame_gmp(uplo, "U");
- if (!upper && !Mlsame_gmp(uplo, "L")) {
- *info = -1;
- } else if (n < 0) {
- *info = -2;
- } else if (lda < max((mpackint)1, n)) {
- *info = -4;
- }
- if (*info != 0) {
- Mxerbla_gmp("Rsytd2", -(*info));
- return;
- }
-//Quick return if possible
- if (n <= 0)
- return;
- if (upper) {
-//Reduce the upper triangle of A
- for (i = n - 1; i >= 1; i--) {
-//Generate elementary reflector H(i) = I - tau * v * v'
-//to annihilate A(1:i-1,i+1)
- Rlarfg(i, &A[(i - 1) + i * lda], &A[0 + i * lda], 1, &taui);
- e[i - 1] = A[(i - 1) + i * lda];
- if (taui != Zero) {
-//Apply H(i) from both sides to A(1:i,1:i)
- A[(i - 1) + i * lda] = One;
-//Compute x := tau * A * v storing x in TAU(1:i)
- Rsymv(uplo, i, taui, A, lda, &A[0 + i * lda], 1, Zero, tau, 1);
-//Compute w := x - 1/2 * tau * (x'*v) * v
- alpha = -Half * taui * Rdot(i, tau, 1, &A[0 + i * lda], 1);
- Raxpy(i, alpha, &A[0 + i * lda], 1, tau, 1);
-//Apply the transformation as a rank-2 update
-//A := A - v * w' - w * v'
- Rsyr2(uplo, i, -One, &A[0 + i * lda], 1, tau, 1, A, lda);
- A[(i - 1) + i * lda] = e[i - 1];
- }
- d[i] = A[i + i * lda];
- tau[i - 1] = taui;
- }
- d[0] = A[0];
- } else {
-//Reduce the lower triangle of A
- for (i = 1; i <= n - 1; i++) {
-//Generate elementary reflector H(i) = I - tau * v * v'
-//to annihilate A(i+2:n,i)
- Rlarfg(n - i, &A[i + (i - 1) * lda], &A[min(i + 2,
- n) - 1 + (i - 1) * lda], 1, &taui);
- e[i - 1] = A[i + (i - 1) * lda];
- if (taui != Zero) {
-//Apply H(i) from both sides to A(i+1:n,i+1:n)
- A[i + (i - 1) * lda] = One;
-//Compute x := tau * A * v storing y in TAU(i:n-1)
- Rsymv(uplo, n - i, taui, &A[i + i * lda],
- lda, &A[i + (i - 1) * lda], 1, Zero, &tau[i - 1], 1);
-//Compute w := x - 1/2 * tau * (x'*v) * v
- alpha =
- -Half * taui * Rdot(n - i, &tau[i - 1], 1,
- &A[i + (i - 1) * lda], 1);
- Raxpy(n - i, alpha, &A[i + (i - 1) * lda], 1, &tau[i - 1], 1);
-//Apply the transformation as a rank-2 update:
-//A := A - v * w' - w * v'
- Rsyr2(uplo, n - i, -One, &A[i + (i - 1) * lda], 1, &tau[i - 1],
- 1, &A[i + i * lda], lda);
- A[i + (i - 1) * lda] = e[i - 1];
- }
- d[i - 1] = A[(i - 1) + (i - 1) * lda];
- tau[i - 1] = taui;
- }
- d[n - 1] = A[(n - 1) + (n - 1) * lda];
- }
- return;
-}
diff --git a/mpack/Rsytrd.cpp b/mpack/Rsytrd.cpp
deleted file mode 100644
index af6fe3d..0000000
--- a/mpack/Rsytrd.cpp
+++ /dev/null
@@ -1,187 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rsytrd.cpp,v 1.7 2009/09/22 21:22:09 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-
-void
-Rsytrd(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpf_class * d,
- mpf_class * e, mpf_class * tau, mpf_class * work, mpackint lwork, mpackint *info)
-{
- mpackint upper, lquery, nb, lwkopt, nx, iws;
- mpackint ldwork, nbmin, kk;
- mpackint i, j;
- mpackint iinfo;
- mpf_class One = 1.0;
-
- *info = 0;
- upper = Mlsame_gmp(uplo, "U");
- lquery = 0;
- if (lwork == -1)
- lquery = 1;
-
- if (!upper && !Mlsame_gmp(uplo, "L")) {
- *info = -1;
- } else if (n < 0) {
- *info = -2;
- } else if (lda < max((mpackint)1, n)) {
- *info = -4;
- } else if (lwork < 1 && !lquery) {
- *info = -9;
- }
- if (*info == 0) {
-//Determine the block size.
- nb = iMlaenv_gmp(1, "Rsytrd", uplo, n, -1, -1, -1);
- lwkopt = n * nb;
- work[0] = (double)lwkopt; //cast from mpackint to mpf
- }
- if (*info != 0) {
- Mxerbla_gmp("Rsytrd", -(*info));
- return;
- } else if (lquery) {
- return;
- }
-//Quick return if possible
- if (n == 0) {
- work[0] = One;
- return;
- }
-
- nx = n;
- iws = 1;
- if (nb > 1 && nb < n) {
-//Determine when to cross over from blocked to unblocked code
-//(last block is always handled by unblocked code).
- nx = max(nb, iMlaenv_gmp(3, "Rsytrd", uplo, n, -1, -1, -1));
- if (nx < n) {
-//Determine if workspace is large enough for blocked code.
- ldwork = n;
- iws = ldwork * nb;
- if (lwork < iws) {
-//Not enough workspace to use optimal NB: determine the
-//minimum value of NB, and reduce NB or force use of
-//unblocked code by setting NX = N.
- nb = max(lwork / ldwork, (mpackint)1);
- nbmin = iMlaenv_gmp(2, "Rsytrd", uplo, n, -1, -1, -1);
- if (nb < nbmin) {
- nx = n;
- }
- }
- } else {
- nx = n;
- }
- } else {
- nb = 1;
- }
- if (upper) {
-//Reduce the upper triangle of A.
-//Columns 1:kk are handled by the unblocked method.
- kk = n - ((n - nx + nb - 1) / nb) * nb;
- for (i = n - nb + 1; i >= kk + 1; i = i - nb) {
-// Reduce columns i:i+nb-1 to tridiagonal form and form the
-//matrix W which is needed to update the unreduced part of
-//the matrix
- Rlatrd(uplo, i + nb - 1, nb, A, lda, e, tau, work, ldwork);
-//Update the unreduced submatrix A(1:i-1,1:i-1), using an
-//update of the form: A := A - V*W' - W*V'
- Rsyr2k(uplo, "No transpose", i - 1, nb, -One,
- &A[0 + (i - 1) * lda], lda, work, ldwork, One, A, lda);
-//Copy superdiagonal elements back into A, and diagonal
-//elements into D
- for (j = i; j <= i + nb - 1; j++) {
- A[(j - 2) + (j - 1) * lda] = e[j - 2];
- d[j - 1] = A[(j - 1) + (j - 1) * lda];
- }
- }
-//Use unblocked code to reduce the last or only block
- Rsytd2(uplo, kk, A, lda, d, e, tau, &iinfo);
- } else {
-//Reduce the lower triangle of A
- for (i = 1; i <= n - nx; i = i + nb) {
-//Reduce columns i:i+nb-1 to tridiagonal form and form the
-//matrix W which is needed to update the unreduced part of
-//the matrix
- Rlatrd(uplo, n - i + 1, nb, &A[(i - 1) + (i - 1) * lda], lda,
- &e[i - 1], &tau[i - 1], work, ldwork);
-//Update the unreduced submatrix A(i+ib:n,i+ib:n), using
-//an update of the form: A := A - V*W' - W*V'
- Rsyr2k(uplo, "No transpose", n - i - nb + 1, nb, -One,
- &A[(i + nb - 1) + (i - 1) * lda], lda, &work[nb], ldwork, One,
- &A[(i + nb - 1) + (i + nb - 1) * lda], lda);
-//Copy subdiagonal elements back into A, and diagonal
-//elements into D
- for (j = i; j <= i + nb - 1; j++) {
- A[j + (j - 1) * lda] = e[j - 1];
- d[j - 1] = A[(j - 1) + (j - 1) * lda];
- }
- }
-//Use unblocked code to reduce the last or only block
- Rsytd2(uplo, n - i + 1, &A[(i - 1) + (i - 1) * lda], lda, &d[i - 1],
- &e[i - 1], &tau[i - 1], &iinfo);
- }
- work[0] = (double)lwkopt; //cast mpf to mpackint
- return;
-}
diff --git a/mpack/Rtrmm.cpp b/mpack/Rtrmm.cpp
deleted file mode 100644
index 321206d..0000000
--- a/mpack/Rtrmm.cpp
+++ /dev/null
@@ -1,283 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rtrmm.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dtrmm.f
-Rtrmm performs one of the matrix-matrix operations
- B := alpha*op(A)*B, or B := alpha*B*op(A),
-where alpha is a scalar, B is an m by n matrix, A is a unit, or
-non-unit, upper or lower triangular matrix and op(A) is one of
- op(A) = A or op(A) = A'.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rtrmm(const char *side, const char *uplo, const char *transa, const char *diag,
- mpackint m, mpackint n, mpf_class alpha, mpf_class * A, mpackint lda,
- mpf_class * B, mpackint ldb)
-{
- mpackint info, lside, nrowa, nounit, upper;
-
- mpf_class temp;
-
- mpf_class Zero = 0.0, One = 1.0;
-
- //test the input parameters.
- lside = Mlsame_gmp(side, "L");
- if (lside)
- nrowa = m;
- else
- nrowa = n;
-
- nounit = Mlsame_gmp(diag, "N");
- upper = Mlsame_gmp(uplo, "U");
-
- info = 0;
- if ((!lside) && (!Mlsame_gmp(side, "R")))
- info = 1;
- else if ((!upper) && (!Mlsame_gmp(uplo, "L")))
- info = 2;
- else if ((!Mlsame_gmp(transa, "N")) && (!Mlsame_gmp(transa, "T"))
- && (!Mlsame_gmp(transa, "C")))
- info = 3;
- else if ((!Mlsame_gmp(diag, "U")) && (!Mlsame_gmp(diag, "N")))
- info = 4;
- else if (m < 0)
- info = 5;
- else if (n < 0)
- info = 6;
- else if (lda < max((mpackint) 1, nrowa))
- info = 9;
- else if (ldb < max((mpackint) 1, m))
- info = 11;
- if (info != 0) {
- Mxerbla_gmp("Rtrmm ", info);
- return;
- }
- //quick return if possible.
- if (m == 0 || n == 0)
- return;
-
- //and when alpha==Zero.
- if (alpha == Zero) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = Zero;
- }
- }
- return;
- }
- //start the operations.
- if (lside) {
- if (Mlsame_gmp(transa, "N")) {
- //Form B := alpha*A*B.
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint k = 0; k < m; k++) {
- if (B[k + j * ldb] != Zero) {
- temp = alpha * B[k + j * ldb];
- for (mpackint i = 0; i < k; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] + temp * A[i + k * lda];
- }
- if (nounit)
- temp = temp * A[k + k * lda];
- B[k + j * ldb] = temp;
- }
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint k = m - 1; k >= 0; k--) {
- if (B[k + j * ldb] != Zero) {
- temp = alpha * B[k + j * ldb];
- B[k + j * ldb] = temp;
- if (nounit)
- B[k + j * ldb] =
- B[k + j * ldb] * A[k + k * lda];
- for (mpackint i = k + 1; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] + temp * A[i + k * lda];
- }
- }
- }
- }
- }
- } else {
- //Form B := alpha*A'*B.
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = m - 1; i >= 0; i--) {
- temp = B[i + j * ldb];
- if (nounit)
- temp = temp * A[i + i * lda];
- for (mpackint k = 0; k < i; k++) {
- temp = temp + A[k + i * lda] * B[k + j * ldb];
- }
- B[i + j * ldb] = alpha * temp;
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i < m; i++) {
- temp = B[i + j * ldb];
- if (nounit)
- temp = temp * A[i + i * lda];
- for (mpackint k = i + 1; k < m; k++) {
- temp = temp + A[k + i * lda] * B[k + j * ldb];
- }
- B[i + j * ldb] = alpha * temp;
- }
- }
- }
- }
- } else {
- if (Mlsame_gmp(transa, "N")) {
- //Form B := alpha*B*A.
- if (upper) {
- for (mpackint j = n - 1; j >= 0; j--) {
- temp = alpha;
- if (nounit)
- temp = temp * A[j + j * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = temp * B[i + j * ldb];
- }
- for (mpackint k = 0; k < j; k++) {
- if (A[k + j * lda] != Zero) {
- temp = alpha * A[k + j * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] + temp * B[i + k * ldb];
- }
- }
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- temp = alpha;
- if (nounit)
- temp = temp * A[j + j * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = temp * B[i + j * ldb];
- }
- for (mpackint k = j + 1; k < n; k++) {
- if (A[k + j * lda] != Zero) {
- temp = alpha * A[k + j * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] + temp * B[i + k * ldb];
- }
- }
- }
- }
- }
- } else {
- if (upper) {
- for (mpackint k = 0; k < n; k++) {
- for (mpackint j = 0; j < k; j++) {
- if (A[j + k * lda] != Zero) {
- temp = alpha * A[j + k * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] + temp * B[i + k * ldb];
- }
- }
- }
- temp = alpha;
- if (nounit)
- temp = temp * A[k + k * lda];
- if (temp != One) {
- for (mpackint i = 0; i < m; i++) {
- B[i + k * ldb] = temp * B[i + k * ldb];
- }
- }
- }
- } else {
- for (mpackint k = n - 1; k >= 0; k--) {
- for (mpackint j = k + 1; j < n; j++) {
- if (A[j + k * lda] != Zero) {
- temp = alpha * A[j + k * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] + temp * B[i + k * ldb];
- }
- }
- }
- temp = alpha;
- if (nounit)
- temp = temp * A[k + k * lda];
- if (temp != One) {
- for (mpackint i = 0; i < m; i++) {
- B[i + k * ldb] = temp * B[i + k * ldb];
- }
- }
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rtrmv.cpp b/mpack/Rtrmv.cpp
deleted file mode 100644
index 484766e..0000000
--- a/mpack/Rtrmv.cpp
+++ /dev/null
@@ -1,189 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rtrmv.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dtrmv.f
-Rtrmv 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.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rtrmv(const char *uplo, const char *trans, const char *diag, mpackint n,
- mpf_class * A, mpackint lda, mpf_class * x, mpackint incx)
-{
- mpackint ix, jx, kx;
-
- mpf_class temp;
-
- mpf_class Zero = 0.0;
-
- //Test the input parameters.
- mpackint info = 0;
-
- if (!Mlsame_gmp(uplo, "U") && !Mlsame_gmp(uplo, "L"))
- info = 1;
- else if (!Mlsame_gmp(trans, "N") && !Mlsame_gmp(trans, "T") && !Mlsame_gmp(trans, "C"))
- info = 2;
- else if (!Mlsame_gmp(diag, "U") && !Mlsame_gmp(diag, "N"))
- info = 3;
- else if (n < 0)
- info = 4;
- else if (lda < max((mpackint) 1, n))
- info = 6;
- else if (incx == 0)
- info = 8;
-
- if (info != 0) {
- Mxerbla_gmp("Rtrmv ", info);
- return;
- }
- //quick return if possible.
- if (n == 0)
- return;
-
- mpackint nounit = Mlsame_gmp(diag, "N");
-
- //set up the start point in x if the increment is not unity. this
- //will be (n-1)*incx too small for descending loops.
- if (incx <= 0)
- kx = -(n - 1) * incx;
- else
- kx = 0;
-
- //start the operations. in this version the elements of a are
- //accessed sequentially with one pass through A.
- if (Mlsame_gmp(trans, "N")) {
- //form x := A*x.
- if (Mlsame_gmp(uplo, "U")) {
- jx = kx;
- for (mpackint j = 0; j < n; j++) {
- if (x[jx] != Zero) {
- temp = x[jx];
- ix = kx;
- for (mpackint i = 0; i < j; i++) {
- x[ix] = x[ix] + temp * A[i + j * lda];
- ix = ix + incx;
- }
- if (nounit)
- x[jx] = x[jx] * A[j + j * lda];
- }
- jx = jx + incx;
- }
- } else {
- kx = kx + (n - 1) * incx;
- jx = kx;
- for (mpackint j = n - 1; j >= 0; j--) {
- if (x[jx] != Zero) {
- temp = x[jx];
- ix = kx;
- for (mpackint i = n - 1; i >= j + 1; i--) {
- x[ix] = x[ix] + temp * A[i + j * lda];
- ix = ix - incx;
- }
- if (nounit)
- x[jx] = x[jx] * A[j + j * lda];
- }
- jx = jx - incx;
- }
- }
- } else {
- //form x := A'*x.
- if (Mlsame_gmp(uplo, "U")) {
- jx = kx + (n - 1) * incx;
- for (mpackint j = n - 1; j >= 0; j--) {
- temp = x[jx];
- ix = jx;
- if (nounit)
- temp = temp * A[j + j * lda];
- for (mpackint i = j - 1; i >= 0; i--) {
- ix = ix - incx;
- temp = temp + A[i + j * lda] * x[ix];
- }
- x[jx] = temp;
- jx = jx - incx;
- }
- } else {
- jx = kx;
- for (mpackint j = 0; j < n; j++) {
- temp = x[jx];
- ix = jx;
- if (nounit)
- temp = temp * A[j + j * lda];
- for (mpackint i = j + 1; i < n; i++) {
- ix = ix + incx;
- temp = temp + A[i + j * lda] * x[ix];
- }
- x[jx] = temp;
- jx = jx + incx;
- }
- }
- }
- return;
-}
diff --git a/mpack/Rtrsm.cpp b/mpack/Rtrsm.cpp
deleted file mode 100644
index 74489ce..0000000
--- a/mpack/Rtrsm.cpp
+++ /dev/null
@@ -1,310 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rtrsm.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dtrsm.f
-Rtrsm solves one of the matrix equations
- op( A )*X = alpha*B, or X*op( A ) = alpha*B,
-where alpha is a scalar, X and B are m by n matrices, A is a unit, or
-non-unit, upper or lower triangular matrix and op( A ) is one of
- op( A ) = A or op( A ) = A'.
-The matrix X is overwritten on B.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rtrsm(const char *side, const char *uplo, const char *transa, const char *diag,
- mpackint m, mpackint n, mpf_class alpha, mpf_class * A, mpackint lda,
- mpf_class * B, mpackint ldb)
-{
- mpackint info, lside, nrowa, nounit, upper;
-
- mpf_class Zero = 0.0, One = 1.0;
-
- mpf_class temp;
-
- //test the input parameters.
- lside = Mlsame_gmp(side, "L");
- if (lside)
- nrowa = m;
- else
- nrowa = n;
-
- nounit = Mlsame_gmp(diag, "N");
- upper = Mlsame_gmp(uplo, "U");
-
- info = 0;
- if ((!lside) && (!Mlsame_gmp(side, "R")))
- info = 1;
- else if ((!upper) && (!Mlsame_gmp(uplo, "L")))
- info = 2;
- else if ((!Mlsame_gmp(transa, "N")) && (!Mlsame_gmp(transa, "T"))
- && (!Mlsame_gmp(transa, "C")))
- info = 3;
- else if ((!Mlsame_gmp(diag, "U")) && (!Mlsame_gmp(diag, "N")))
- info = 4;
- else if (m < 0)
- info = 5;
- else if (n < 0)
- info = 6;
- else if (lda < max((mpackint) 1, nrowa))
- info = 9;
- else if (ldb < max((mpackint) 1, m))
- info = 11;
- if (info != 0) {
- Mxerbla_gmp("Rtrsm ", info);
- return;
- }
- //quick return if possible.
- if (m == 0 || n == 0)
- return;
-
- //and when alpha==zero.
- if (alpha == Zero) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = Zero;
- }
- }
- return;
- }
- //start the operations.
- if (lside) {
- if (Mlsame_gmp(transa, "N")) {
- //Form B := alpha*inv(A)*B.
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- if (alpha != One) {
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = alpha * B[i + j * ldb];
- }
- }
- for (mpackint k = m - 1; k >= 0; k--) {
- if (B[k + j * ldb] != Zero) {
- if (nounit)
- B[k + j * ldb] =
- B[k + j * ldb] / A[k + k * lda];
- for (mpackint i = 0; i < k; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] - B[k + j * ldb] * A[i +
- k * lda];
- }
- }
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- if (alpha != One) {
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = alpha * B[i + j * ldb];
- }
- }
- for (mpackint k = 0; k < m; k++) {
- if (B[k + j * ldb] != Zero) {
- if (nounit)
- B[k + j * ldb] =
- B[k + j * ldb] / A[k + k * lda];
- for (mpackint i = k + 1; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] - B[k + j * ldb] * A[i +
- k * lda];
- }
- }
- }
- }
- }
- } else {
- //Form B := alpha*inv(A')*B.
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = 0; i < m; i++) {
- temp = alpha * B[i + j * ldb];
- for (mpackint k = 0; k < i; k++) {
- temp = temp - A[k + i * lda] * B[k + j * ldb];
- }
- if (nounit)
- temp = temp / A[i + i * lda];
- B[i + j * ldb] = temp;
- }
- }
- } else {
- for (mpackint j = 0; j < n; j++) {
- for (mpackint i = m - 1; i >= 0; i--) {
- temp = alpha * B[i + j * ldb];
- for (mpackint k = i + 1; k < m; k++) {
- temp = temp - A[k + i * lda] * B[k + j * ldb];
- }
- if (nounit)
- temp = temp / A[i + i * lda];
- B[i + j * ldb] = temp;
- }
- }
- }
- }
- } else {
- if (Mlsame_gmp(transa, "N")) {
- //Form B := alpha*B*inv(A).
- if (upper) {
- for (mpackint j = 0; j < n; j++) {
- if (alpha != One) {
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = alpha * B[i + j * ldb];
- }
- }
- for (mpackint k = 0; k < j; k++) {
- if (A[k + j * lda] != Zero) {
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] - A[k + j * lda] * B[i +
- k * ldb];
- }
- }
- }
- if (nounit) {
- temp = One / A[j + j * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = temp * B[i + j * ldb];
- }
- }
- }
- } else {
- for (mpackint j = n - 1; j >= 0; j--) {
- if (alpha != One) {
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = alpha * B[i + j * ldb];
- }
- }
- for (mpackint k = j + 1; k < n; k++) {
- if (A[k + j * lda] != Zero) {
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] - A[k + j * lda] * B[i +
- k * ldb];
- }
- }
- }
- if (nounit) {
- temp = One / A[j + j * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] = temp * B[i + j * ldb];
- }
- }
- }
- }
- } else {
- //Form B := alpha*B*inv(A').
- if (upper) {
- for (mpackint k = n - 1; k >= 0; k--) {
- if (nounit) {
- temp = One / A[k + k * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + k * ldb] = temp * B[i + k * ldb];
- }
- }
- for (mpackint j = 0; j < k; j++) {
- if (A[j + k * lda] != Zero) {
- temp = A[j + k * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] - temp * B[i + k * ldb];
- }
- }
- }
- if (alpha != One) {
- for (mpackint i = 0; i < m; i++) {
- B[i + k * ldb] = alpha * B[i + k * ldb];
- }
- }
- }
- } else {
- for (mpackint k = 0; k < n; k++) {
- if (nounit) {
- temp = One / A[k + k * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + k * ldb] = temp * B[i + k * ldb];
- }
- }
- for (mpackint j = k + 1; j < n; j++) {
- if (A[j + k * lda] != Zero) {
- temp = A[j + k * lda];
- for (mpackint i = 0; i < m; i++) {
- B[i + j * ldb] =
- B[i + j * ldb] - temp * B[i + k * ldb];
- }
- }
- }
- if (alpha != One) {
- for (mpackint i = 0; i < m; i++) {
- B[i + k * ldb] = alpha * B[i + k * ldb];
- }
- }
- }
- }
- }
- }
- return;
-}
diff --git a/mpack/Rtrsv.cpp b/mpack/Rtrsv.cpp
deleted file mode 100644
index ff2de21..0000000
--- a/mpack/Rtrsv.cpp
+++ /dev/null
@@ -1,187 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: Rtrsv.cpp,v 1.4 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-/*
-Based on http://www.netlib.org/blas/dtrsv.f
-Rtrsv 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.
-*/
-
-#include <mblas_gmp.h>
-
-void
-Rtrsv(const char *uplo, const char *trans, const char *diag, mpackint n,
- mpf_class * A, mpackint lda, mpf_class * x, mpackint incx)
-{
- mpackint ix, jx, kx;
-
- mpf_class Zero = 0.0;
-
- mpf_class temp;
-
-//Test the input parameters.
- mpackint info = 0;
-
- if (!Mlsame_gmp(uplo, "U") && !Mlsame_gmp(uplo, "L"))
- info = 1;
- else if (!Mlsame_gmp(trans, "N") && !Mlsame_gmp(trans, "T") && !Mlsame_gmp(trans, "C"))
- info = 2;
- else if (!Mlsame_gmp(diag, "U") && !Mlsame_gmp(diag, "N"))
- info = 3;
- else if (n < 0)
- info = 4;
- else if (lda < max((mpackint) 1, n))
- info = 6;
- else if (incx == 0)
- info = 8;
- if (info != 0) {
- Mxerbla_gmp("Rtrsv ", info);
- return;
- }
- //quick return if possible.
- if (n == 0)
- return;
-
- mpackint nounit = Mlsame_gmp(diag, "N");
-
- //set up the start point in x if the increment is not unity. this
- //will be (n-1)*incx too small for descending loops.
- if (incx <= 0)
- kx = (1 - n) * incx;
- else
- kx = 0;
-
- //start the operations. in this version the elements of a are
- //accessed sequentially with one pass through A.
- if (Mlsame_gmp(trans, "N")) {
- //form x := inv(A)*x.
- if (Mlsame_gmp(uplo, "U")) {
- jx = kx + (n - 1) * incx;
- for (mpackint j = n - 1; j >= 0; j--) {
- if (x[jx] != Zero) {
- if (nounit)
- x[jx] = x[jx] / A[j + j * lda];
- temp = x[jx];
- ix = jx;
- for (mpackint i = j - 1; i >= 0; i--) {
- ix = ix - incx;
- x[ix] = x[ix] - temp * A[i + j * lda];
- }
- }
- jx = jx - incx;
- }
- } else {
- jx = kx;
- for (mpackint j = 0; j < n; j++) {
- if (x[jx] != Zero) {
- if (nounit)
- x[jx] = x[jx] / A[j + j * lda];
- temp = x[jx];
- ix = jx;
- for (mpackint i = j + 1; i < n; i++) {
- ix = ix + incx;
- x[ix] = x[ix] - temp * A[i + j * lda];
- }
- }
- jx = jx + incx;
- }
- }
- } else {
- //form x := inv(A')*x.
- if (Mlsame_gmp(uplo, "U")) {
- jx = kx;
- for (mpackint j = 0; j < n; j++) {
- ix = kx;
- temp = x[jx];
- for (mpackint i = 0; i <= j - 1; i++) {
- temp = temp - A[i + j * lda] * x[ix];
- ix = ix + incx;
- }
- if (nounit)
- temp = temp / A[j + j * lda];
- x[jx] = temp;
- jx = jx + incx;
- }
- } else {
- kx = kx + (n - 1) * incx;
- jx = kx;
- for (mpackint j = n - 1; j >= 0; j--) {
- ix = kx;
- temp = x[jx];
- for (mpackint i = n - 1; i >= j + 1; i--) {
- temp = temp - A[i + j * lda] * x[ix];
- ix = ix - incx;
- }
- if (nounit)
- temp = temp / A[j + j * lda];
- x[jx] = temp;
- jx = jx - incx;
- }
- }
- }
-}
diff --git a/mpack/iMlaenv.cpp b/mpack/iMlaenv.cpp
deleted file mode 100644
index ca2545d..0000000
--- a/mpack/iMlaenv.cpp
+++ /dev/null
@@ -1,291 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: iMlaenv.cpp,v 1.5 2009/09/12 07:59:10 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-/*
-Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
-
-$COPYRIGHT$
-
-Additional copyrights may follow
-
-$HEADER$
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-- Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer listed
- in this license in the documentation and/or other materials
- provided with the distribution.
-
-- Neither the name of the copyright holders nor the names of its
- contributors may be used to endorse or promote products derived from
- this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*/
-
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
-#include <string.h>
-#include <ctype.h>
-
-#define MLANAMESIZE 6
-
-//ISPEC = 1: block size
-//In these examples, separate code is provided for setting NB for
-//real and complex. We assume that NB will take the same value in
-//single or double precision.
-
-mpackint
-iMlaenv1(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- mpackint nb = 1;
-#if !defined (IMLAENV_DEBUG)
- if (strcmp(&Mlaname[1],"orgqr") == 0) { nb = 32; return nb; }
- if (strcmp(&Mlaname[1],"orgql") == 0) { nb = 32; return nb; }
- if (strcmp(&Mlaname[1],"potrf") == 0) { nb = 64; return nb; }
- if (strcmp(&Mlaname[1],"trtri") == 0) { nb = 64; return nb; }
- if (strcmp(&Mlaname[1],"dsytrd") == 0) { nb = 32;return nb; }
- if (strcmp(&Mlaname[1],"getrf") == 0) { nb = 64;return nb; }
- if (strcmp(&Mlaname[1],"getri") == 0) { nb = 64;return nb; }
-#else
- if (strcmp(&Mlaname[1],"potrf") == 0) { nb = 8;return nb; }
- if (strcmp(&Mlaname[1],"orgqr") == 0) { nb = 8;return nb; }
- if (strcmp(&Mlaname[1],"orgql") == 0) { nb = 8;return nb; }
- if (strcmp(&Mlaname[1],"trtri") == 0) { nb = 8;return nb; }
- if (strcmp(&Mlaname[0],"dsytrd") == 0) { nb = 8;return nb; }
- if (strcmp(&Mlaname[1],"getrf") == 0) { nb = 8;return nb; }
- if (strcmp(&Mlaname[1],"getri") == 0) { nb = 8;return nb; }
-#endif
- return nb;
-}
-
-//* ISPEC = 2: minimum block size
-mpackint
-iMlaenv2(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- mpackint nbmin = 1;
- if (strcmp(&Mlaname[1], "orgqr") == 0) { nbmin = 2; return nbmin; }
- if (strcmp(&Mlaname[1], "orgql") == 0) { nbmin = 2; return nbmin; }
- if (strcmp(&Mlaname[1], "trtri") == 0) { nbmin = 2; return nbmin; }
- if (strcmp(&Mlaname[0], "dsytrd") == 0) { nbmin = 2; return nbmin; }
- if (strcmp(&Mlaname[0], "getri") == 0) { nbmin = 2; return nbmin; }
-
- return nbmin;
-}
-
-// ISPEC = 3: crossover point
-mpackint
-iMlaenv3(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- mpackint nx = 1;
-#if !defined (IMLAENV_DEBUG)
- if (strcmp(&Mlaname[1],"orgqr")==0) { nx = 128; return nx; }
- if (strcmp(&Mlaname[1],"orgql")==0) { nx = 128; return nx; }
- if (strcmp(&Mlaname[0],"dsytrd")==0){ nx = 32; return nx; }
-#else
- if (strcmp(&Mlaname[1],"orgqr") == 0) { nx = 6; return nx; }
- if (strcmp(&Mlaname[1],"orgql") == 0) { nx = 6; return nx; }
- if (strcmp(&Mlaname[0], "dsytrd")== 0){ nx = 6; return nx; }
-#endif
- return nx;
-}
-
-mpackint
-iMlaenv4(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv5(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv6(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv7(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv8(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv9(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3, mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv10(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3,
- mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv11(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3,
- mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv12(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3,
- mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv13(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3,
- mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv14(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3,
- mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv15(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3,
- mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv16(const char *Mlaname, const char *opts, mpackint n1, mpackint n2, mpackint n3,
- mpackint n4)
-{
- return 1;
-}
-
-mpackint
-iMlaenv_gmp(mpackint ispec, const char *name, const char *opts, mpackint n1, mpackint n2, mpackint n3,
- mpackint n4)
-{
- mpackint iret, i, up;
-
- iret = -1;
-
- char Mlaname[MLANAMESIZE + 1];
-//buggy
- strncpy(Mlaname, name, MLANAMESIZE);
- for (i = 0; i < MLANAMESIZE; i++) {
- up = tolower(Mlaname[i]);
- Mlaname[i] = up;
- }
-
- if (!Mlsame_gmp(Mlaname, "r") && !Mlsame_gmp(Mlaname, "c"))
- return iret;
-
- switch (ispec) {
- case 1:
- iret = iMlaenv1(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 2:
- iret = iMlaenv2(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 3:
- iret = iMlaenv3(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 4:
- iret = iMlaenv4(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 5:
- iret = iMlaenv5(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 6:
- iret = iMlaenv6(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 7:
- iret = iMlaenv7(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 8:
- iret = iMlaenv8(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 9:
- iret = iMlaenv9(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 10:
- iret = iMlaenv10(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 11:
- iret = iMlaenv11(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 12:
- iret = iMlaenv12(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 13:
- iret = iMlaenv13(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 14:
- iret = iMlaenv14(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 15:
- iret = iMlaenv15(Mlaname, opts, n1, n2, n3, n4);
- break;
- case 16:
- iret = iMlaenv16(Mlaname, opts, n1, n2, n3, n4);
- break;
- default:
- iret = -1;
- }
- return iret;
-}
diff --git a/mpack/mblas_gmp.h b/mpack/mblas_gmp.h
deleted file mode 100644
index 0c0320b..0000000
--- a/mpack/mblas_gmp.h
+++ /dev/null
@@ -1,96 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2009 by Nakata, Maho
- *
- * $Id: mblas_gmp.h,v 1.8 2009/09/17 00:59:02 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-/* this is a subset of mpack for SDPA-GMP only */
-/* http://mplapack.sourceforge.net/ */
-
-#ifndef _MBLAS_GMP_H_
-#define _MBLAS_GMP_H_
-
-#include <mpack_config.h>
-#include <gmpxx.h>
-#include <mutils_gmp.h>
-
-#if !defined __MPACK_ERRNO__
-#define _MPACK_EXTERN_ extern
-#else
-#define _MPACK_EXTERN_
-#endif
-
-_MPACK_EXTERN_ int mpack_errno;
-
-/* LEVEL 1 MBLAS */
-void Rrotg(mpf_class * da, mpf_class * db, mpf_class * c, mpf_class * s);
-void Rrot(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy, mpackint incy, mpf_class c, mpf_class s);
-mpf_class Rdot(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy,
- mpackint incy);
-void Rcopy(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy,
- mpackint incy);
-void Raxpy(mpackint n, mpf_class da, mpf_class * dx, mpackint incx, mpf_class * dy, mpackint incy);
-void Rscal(mpackint n, mpf_class ca, mpf_class * cx, mpackint incx);
-int Mlsame_gmp(const char *a, const char *b);
-void Mxerbla_gmp(const char *srname, int info);
-void Rswap(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy,
- mpackint incy);
-mpf_class Rnrm2(mpackint n, mpf_class * x, mpackint incx);
-
-/* LEVEL 2 MBLAS */
-void Rtrmv(const char *uplo, const char *trans, const char *diag, mpackint n,
- mpf_class * A, mpackint lda, mpf_class * x, mpackint incx);
-void Rtrsv(const char *uplo, const char *trans, const char *diag, mpackint n,
- mpf_class * A, mpackint lda, mpf_class * x, mpackint incx);
-void Rgemv(const char *trans, mpackint m, mpackint n, mpf_class alpha,
- mpf_class * A, mpackint lda, mpf_class * x, mpackint incx, mpf_class beta,
- mpf_class * y, mpackint incy);
-void Rsymv(const char *uplo, mpackint n, mpf_class alpha, mpf_class * A,
- mpackint lda, mpf_class * x, mpackint incx, mpf_class beta, mpf_class * y,
- mpackint incy);
-void Rsyr2(const char *uplo, mpackint n, mpf_class alpha, mpf_class * x,
- mpackint incx, mpf_class * y, mpackint incy, mpf_class * A, mpackint lda);
-void Rger(mpackint m, mpackint n, mpf_class alpha, mpf_class * x,
- mpackint incx, mpf_class * y, mpackint incy, mpf_class * A, mpackint lda);
-
-/* LEVEL 3 MBLAS */
-void Rtrmm(const char *side, const char *uplo, const char *transa,
- const char *diag, mpackint m, mpackint n, mpf_class alpha, mpf_class * A,
- mpackint lda, mpf_class * B, mpackint ldb);
-void Rtrsm(const char *side, const char *uplo, const char *transa,
- const char *diag, mpackint m, mpackint n, mpf_class alpha, mpf_class * A,
- mpackint lda, mpf_class * B, mpackint ldb);
-void Rgemm(const char *transa, const char *transb, mpackint m, mpackint n,
- mpackint k, mpf_class alpha, mpf_class * A, mpackint lda, mpf_class * B,
- mpackint ldb, mpf_class beta, mpf_class * C, mpackint ldc);
-void Rsyr2k(const char *uplo, const char *trans, mpackint n, mpackint k,
- mpf_class alpha, mpf_class * A, mpackint lda, mpf_class * B, mpackint ldb,
- mpf_class beta, mpf_class * C, mpackint ldc);
-void Rsyrk(const char *uplo, const char *trans, mpackint n, mpackint k,
- mpf_class alpha, mpf_class * A, mpackint lda, mpf_class beta,
- mpf_class * C, mpackint ldc);
-
-#endif
diff --git a/mpack/mlapack_gmp.h b/mpack/mlapack_gmp.h
deleted file mode 100644
index 4f98cd9..0000000
--- a/mpack/mlapack_gmp.h
+++ /dev/null
@@ -1,92 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: mlapack_gmp.h,v 1.6 2009/09/22 20:27:18 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-#ifndef _MLAPACK_GMP_H_
-#define _MLAPACK_GMP_H_
-
-/* this is a subset of mpack for SDPA-GMP only */
-/* http://mplapack.sourceforge.net/ */
-
-/* mlapack prototypes */
-void Rsteqr(const char *compz, mpackint n, mpf_class * d, mpf_class * e,
- mpf_class * Z, mpackint ldz, mpf_class * work, mpackint *info);
-void
- Rsyev(const char *jobz, const char *uplo, mpackint n, mpf_class * A,
- mpackint lda, mpf_class * w, mpf_class * work, mpackint *lwork, mpackint *info);
-void Rpotrf(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpackint *info);
-mpackint iMlaenv_gmp(mpackint ispec, const char *name, const char *opts, mpackint n1, mpackint n2,
- mpackint n3, mpackint n4);
-mpf_class Rlamch_gmp(const char *cmach);
-mpf_class Rlansy(const char *norm, const char *uplo, mpackint n, mpf_class * A,
- mpackint lda, mpf_class * work);
-void Rlascl(const char *type, mpackint kl, mpackint ku, mpf_class cfrom, mpf_class cto,
- mpackint m, mpackint n, mpf_class * A, mpackint lda, mpackint *info);
-void Rsytrd(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpf_class * d,
- mpf_class * e, mpf_class * tau, mpf_class * work, mpackint lwork, mpackint *info);
-void Rsytd2(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpf_class * d,
- mpf_class * e, mpf_class * tau, mpackint *info);
-mpf_class Rlanst(const char *norm, mpackint n, mpf_class * d, mpf_class * e);
-void Rlae2(mpf_class a, mpf_class b, mpf_class c, mpf_class * rt1,
- mpf_class * rt2);
-mpf_class Rlapy2(mpf_class x, mpf_class y);
-void Rlasrt(const char *id, mpackint n, mpf_class * d, mpackint *info);
-void Rorgql(mpackint m, mpackint n, mpackint k, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint lwork, mpackint *info);
-void Rorgqr(mpackint m, mpackint n, mpackint k, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint lwork, mpackint *info);
-void Rlarfg(mpackint N, mpf_class * alpha, mpf_class * x, mpackint incx,
- mpf_class * tau);
-void Rlassq(mpackint n, mpf_class * x, mpackint incx, mpf_class * scale,
- mpf_class * sumsq);
-void Rorg2l(mpackint m, mpackint n, mpackint k, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint *info);
-void Rlarft(const char *direct, const char *storev, mpackint n, mpackint k,
- mpf_class * v, mpackint ldv, mpf_class * tau, mpf_class * t, mpackint ldt);
-void Rlarfb(const char *side, const char *trans, const char *direct,
- const char *storev, mpackint m, mpackint n, mpackint k, mpf_class * V, mpackint ldv,
- mpf_class * T, mpackint ldt, mpf_class * C, mpackint ldc, mpf_class * work,
- mpackint ldwork);
-void Rorg2r(mpackint m, mpackint n, mpackint k, mpf_class * A, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint *info);
-void Rlarf(const char *side, mpackint m, mpackint n, mpf_class * v, mpackint incv,
- mpf_class tau, mpf_class * C, mpackint ldc, mpf_class * work);
-void Rpotf2(const char *uplo, mpackint n, mpf_class * A, mpackint lda, mpackint *info);
-void Rlaset(const char *uplo, mpackint m, mpackint n, mpf_class alpha, mpf_class beta,
- mpf_class * A, mpackint lda);
-void Rlaev2(mpf_class a, mpf_class b, mpf_class c, mpf_class * rt1,
- mpf_class * rt2, mpf_class * cs1, mpf_class * sn1);
-void Rlasr(const char *side, const char *pivot, const char *direct, mpackint m,
- mpackint n, mpf_class * c, mpf_class * s, mpf_class * A, mpackint lda);
-void Rlartg(mpf_class f, mpf_class g, mpf_class * cs, mpf_class * sn,
- mpf_class * r);
-void Rlatrd(const char *uplo, mpackint n, mpackint nb, mpf_class * A, mpackint lda, mpf_class * e, mpf_class * tau, mpf_class * w, mpackint ldw);
-void Rsterf(mpackint n, mpf_class * d, mpf_class * e, mpackint *info);
-void Rorgtr(const char *uplo, mpackint n, mpf_class * a, mpackint lda, mpf_class * tau,
- mpf_class * work, mpackint lwork, mpackint *info);
-#endif
diff --git a/mpack/mpack_config.h b/mpack/mpack_config.h
deleted file mode 100644
index 1acc121..0000000
--- a/mpack/mpack_config.h
+++ /dev/null
@@ -1,72 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2008 by Nakata, Maho
- *
- * $Id: mpack_config.h,v 1.7 2009/09/24 07:25:57 nakatamaho Exp $
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-/* work in progress */
-/* put some definitons on mpack */
-
-/* should depend on C compiler and environment
- our intention is that use 64bit int when USE64BITINT is set.
- This should be the default on 64bit environment.
-*/
-
-#ifndef _MPACK_CONFIG_H_
-#define _MPACK_CONFIG_H_
-
-#include <stdlib.h>
-#include <inttypes.h>
-
-// #define USE64BITINT
-
-#ifdef USE64BITINT
-typedef int64_t mpackint;
-#else
-typedef int32_t mpackint;
-#endif
-
-#ifdef USE64BITINT
-inline mpackint mpackabs(mpackint i)
-{
- return labs(i);
-}
-#else
-inline mpackint mpackabs(mpackint i)
-{
- return abs(i);
-}
-#endif
-
-typedef mpackint mpacklogical;
-
-#ifdef __cplusplus
-typedef mpacklogical(*ML_fp) (...);
-#else
-typedef mpacklogical(*ML_fp);
-#endif
-
-#endif
diff --git a/mpack/mutils_gmp.h b/mpack/mutils_gmp.h
deleted file mode 100644
index 809565b..0000000
--- a/mpack/mutils_gmp.h
+++ /dev/null
@@ -1,76 +0,0 @@
-/*************************************************************************
- *
- * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
- *
- * Copyright 2009 by Nakata, Maho
- *
- * MPACK - multiple precision arithmetic library
- *
- * This file is part of MPACK.
- *
- * MPACK is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License version 3
- * only, as published by the Free Software Foundation.
- *
- * MPACK is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License version 3 for more details
- * (a copy is included in the LICENSE file that accompanied this code).
- *
- * You should have received a copy of the GNU Lesser General Public License
- * version 3 along with MPACK. If not, see
- * <http://www.gnu.org/licenses/lgpl.html>
- * for a copy of the LGPLv3 License.
- *
- ************************************************************************/
-
-#ifndef _MUTILS_GMP_H_
-#define _MUTILS_GMP_H_
-
-using std::max;
-using std::min;
-
-mpf_class Msign(mpf_class a, mpf_class b);
-double cast2double(mpf_class a);
-int M2int(mpf_class a);
-void mpf_pow(mpf_t ans, mpf_t x, mpf_t y);
-mpf_class mpf_approx_log(mpf_class x);
-mpf_class mpf_approx_log2(mpf_class x);
-mpf_class mpf_approx_log10(mpf_class x);
-mpf_class mpf_approx_pow(mpf_class x, mpf_class y);
-mpf_class mpf_approx_cos(mpf_class x);
-mpf_class mpf_approx_sin(mpf_class x);
-mpf_class mpf_approx_exp(mpf_class x);
-mpf_class mpf_approx_pi();
-
-//implementation of sign transfer function.
-inline mpf_class
-Msign(mpf_class a, mpf_class b)
-{
- mpf_class mtmp;
- mpf_abs(mtmp.get_mpf_t(), a.get_mpf_t());
- if (b != 0.0) {
- mtmp = mpf_sgn(b.get_mpf_t()) * mtmp;
- }
- return mtmp;
-}
-
-inline double
-cast2double(mpf_class a)
-{
- return a.get_d();
-}
-
-inline int
-M2int(mpf_class a)
-{
- int i;
- mpf_t tmp;
- a = a + 0.5;
- mpf_floor(tmp, a.get_mpf_t());
- i = (int)mpf_get_si(tmp);
- return i;
-}
-
-#endif
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/sdpb.git
More information about the debian-science-commits
mailing list