[sdpb] 01/233: initial commit
Tobias Hansen
thansen at moszumanska.debian.org
Thu Mar 9 04:06:11 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 5dfe2674cce263d87f15f0d7daaeaa2b21d1bac1
Author: David Simmons-Duffin <dsd at romulus.sns.ias.edu>
Date: Thu Jun 12 03:59:35 2014 -0400
initial commit
---
.gitignore | 26 +++
BlockDenseMatrix.h | 39 +++++
DenseMatrix.h | 90 ++++++++++
LowRankConstraintMatrix.h | 29 ++++
Makefile | 38 +++++
main.cpp | 61 +++++++
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/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 | 94 +++++++++++
mpack/mlapack_gmp.h | 92 ++++++++++
mpack/mpack_config.h | 72 ++++++++
mpack/mutils_gmp.h | 76 +++++++++
types.h | 10 ++
61 files changed, 9172 insertions(+)
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..36392d5
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,26 @@
+# Object files
+*.o
+*.lo
+
+# Libraries
+*.lib
+*.a
+
+# Shared objects (inc. Windows DLLs)
+*.dll
+*.so
+*.so.*
+*.dylib
+
+# Executables
+*.exe
+*.out
+*.app
+
+*/src/.libs
+*/src/.deps
+*/config.log
+*/examples
+sdp-bootstrap
+
+.DS_Store
diff --git a/BlockDenseMatrix.h b/BlockDenseMatrix.h
new file mode 100644
index 0000000..8ab8438
--- /dev/null
+++ b/BlockDenseMatrix.h
@@ -0,0 +1,39 @@
+#ifndef SDP_BOOTSTRAP_BLOCKDENSEMATRIX_H_
+#define SDP_BOOTSTRAP_BLOCKDENSEMATRIX_H_
+
+#include <vector>
+#include "types.h"
+#include "DenseMatrix.h"
+
+using std::vector;
+
+class BlockDenseMatrix {
+public:
+ vector<Real> diagonalPart;
+ vector<DenseMatrix> blocks;
+
+ BlockDenseMatrix(const vector<Real> &diagonalPart, const vector<int> &blockSizes):
+ diagonalPart(diagonalPart) {
+ for (unsigned int i = 0; i < blockSizes.size(); i++) {
+ blocks.push_back(DenseMatrix(blockSizes[i]));
+ }
+ }
+
+ void inverseCholeskyAndInverse(BlockDenseMatrix &invCholesky,
+ BlockDenseMatrix &inverse,
+ BlockDenseMatrix &workSpace) {
+
+ for (unsigned int i = 0; i < diagonalPart.size(); i++) {
+ Real d = diagonalPart[i];
+ invCholesky.diagonalPart[i] = 1/sqrt(d);
+ inverse.diagonalPart[i] = 1/d;
+ }
+
+ for (unsigned int b = 0; b < blocks.size(); b++) {
+ blocks[b].inverseCholeskyAndInverse(invCholesky.blocks[b], inverse.blocks[b], workSpace.blocks[b]);
+ }
+ }
+
+};
+
+#endif // SDP_BOOTSTRAP_BLOCKDENSEMATRIX_H_
diff --git a/DenseMatrix.h b/DenseMatrix.h
new file mode 100644
index 0000000..3bc927e
--- /dev/null
+++ b/DenseMatrix.h
@@ -0,0 +1,90 @@
+#ifndef SDP_BOOTSTRAP_DENSEMATRIX_H_
+#define SDP_BOOTSTRAP_DENSEMATRIX_H_
+
+#include <vector>
+#include "types.h"
+
+using std::vector;
+
+class DenseMatrix {
+public:
+ int dim;
+
+ // The elements of the matrix, in column-major order, for
+ // consistency with lapack's conventions.
+ vector<Real> elements;
+
+ DenseMatrix(int dim):
+ dim(dim),
+ elements(vector<Real>(dim*dim, 0)) {}
+
+ inline Real elem(int i, int j) const {
+ return elements[i + j*dim];
+ }
+
+ // thinking of our matrix M as a block matrix where each block has
+ // size v.size() == u.size(), compute the pairing v^T M[ij] u, where
+ // M[ij] denotes the i,j-th block of M
+ Real blockBilinearForm(int i, int j, const vector<Real> &v, const vector<Real> &u) const {
+ int blockDim = v.size();
+
+ Real total = 0;
+ for (int k = 0; k < blockDim; k++) {
+ Real uk = u[k];
+ for (int l = 0; l < blockDim; l++) {
+ total += v[l] * uk * elem(i*blockDim+l, j*blockDim + k);
+ }
+ }
+
+ return total;
+ }
+
+ void setToZero() {
+ std::fill(elements.begin(), elements.end(), 0);
+ }
+
+ void setToIdentity() {
+ setToZero();
+ for (int i = 0; i < dim; i++)
+ elements[i * (dim + 1)] = 1;
+ }
+
+ void choleskyDecomposition(DenseMatrix &result) {
+ mpackint info;
+ Real *resultArray = &result.elements[0];
+ Rcopy(dim*dim, &elements[0], 1, resultArray, 1);
+
+ // The lower-triangular part of result is now our cholesky matrix
+ Rpotrf("Lower", dim, resultArray, dim, &info);
+
+ // Set the upper-triangular part of the result to zero
+ for (int j = 0; j < dim; j++) {
+ for (int i = 0; i < j; i++) {
+ result.elements[i + j*dim] = 0;
+ }
+ }
+ }
+
+ void inverseLowerTriangular(DenseMatrix &result) {
+ result.setToIdentity();
+ Rtrsm("Left", "Lower", "NoTranspose", "NonUnitDiagonal",
+ dim, dim, 1, &elements[0], dim, &result.elements[0], dim);
+ }
+
+ void inverseCholesky(DenseMatrix &result, DenseMatrix &workSpace) {
+ choleskyDecomposition(workSpace);
+ workSpace.inverseLowerTriangular(result);
+ }
+
+ void inverseCholeskyAndInverse(DenseMatrix &invCholesky, DenseMatrix &inverse, DenseMatrix &workSpace) {
+ inverseCholesky(invCholesky, workSpace);
+
+ inverse.elements = invCholesky.elements;
+ Rtrmm("Left", "Lower", "Transpose", "NonUnitDiag", dim, dim, 1,
+ &invCholesky.elements[0], dim,
+ &inverse.elements[0], dim);
+ }
+
+};
+
+#endif // SDP_BOOTSTRAP_DENSEMATRIX_H_
diff --git a/LowRankConstraintMatrix.h b/LowRankConstraintMatrix.h
new file mode 100644
index 0000000..b74406d
--- /dev/null
+++ b/LowRankConstraintMatrix.h
@@ -0,0 +1,29 @@
+#ifndef SDP_BOOTSTRAP_LOWRANKCONSTRAINTMATRIX_H_
+#define SDP_BOOTSTRAP_LOWRANKCONSTRAINTMATRIX_H_
+
+#include <vector>
+#include "types.h"
+
+using std::pair;
+using std::vector;
+
+// A matrix of the form E_{ij} \otimes v v^T, where E_{ij} is the
+// matrix with (i,j)-th entry 1, and the rest zero, and v is a vector.
+class RankOneSingleBlockMatrix {
+public:
+ int i;
+ int j;
+ vector<Real> vec;
+
+ RankOneSingleBlockMatrix(int i, int j, const vector<Real> &vec):
+ i(i), j(j), vec(vec) {}
+};
+
+class LowRankConstraintMatrix {
+public:
+ vector<Real> diagonalPart;
+ vector<pair<int, RankOneSingleBlockMatrix> > lowRankBlocks;
+ vector<pair<int, DenseMatrix> > denseBlocks;
+};
+
+#endif // SDP_BOOTSTRAP_LOWRANKCONSTRAINTMATRIX_H_
diff --git a/Makefile b/Makefile
new file mode 100755
index 0000000..5a1fddc
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,38 @@
+OBJECTS = main.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 = types.h mpack/mblas_gmp.h mpack/mlapack_gmp.h mpack/mpack_config.h mpack/mutils_gmp.h
+SOURCES = $(OJBECTS:.o=.cpp)
+RESULT = sdp-bootstrap
+
+CC = g++
+CFLAGS = -g -O2 -Wall -ansi -pedantic -L/home/dsd/lib -I./mpack -I/home/dsd/include -I/home/dsd/include/boost -fopenmp
+RM = rm -f
+
+.SUFFIXES: .cpp .o
+
+$(RESULT): $(OBJECTS)
+ $(CC) $(CFLAGS) -lgomp -lmblas_gmp -lmlapack_gmp -lgmp -lgmpxx -lmpc -lboost_serialization -lboost_system -lboost_filesystem -o $@ $(OBJECTS)
+
+.cpp.o:
+ $(CC) $(CFLAGS) -c $< -o $@
+
+clean:
+ $(RM) *.o *.core core *~ src/*.o math/*.o
+
+$(OBJECTS): $(HEADERS)
diff --git a/main.cpp b/main.cpp
new file mode 100644
index 0000000..7c2ab8e
--- /dev/null
+++ b/main.cpp
@@ -0,0 +1,61 @@
+#include <iostream>
+#include <vector>
+#include "types.h"
+#include "DenseMatrix.h"
+#include "BlockDenseMatrix.h"
+#include "LowRankConstraintMatrix.h"
+
+using std::cout;
+using std::endl;
+
+Real schurComplementPairing(const LowRankConstraintMatrix &F1,
+ const LowRankConstraintMatrix &F2,
+ const BlockDenseMatrix &X,
+ const BlockDenseMatrix &ZInv) {
+ Real total = 0;
+
+ for (unsigned int k1 = 0; k1 < F1.lowRankBlocks.size(); k1++) {
+ int b1 = F1.lowRankBlocks[k1].first;
+
+ for (unsigned int k2 = 0; k2 < F2.lowRankBlocks.size(); k2++) {
+ int b2 = F2.lowRankBlocks[k2].first;
+
+ if (b1 == b2) {
+ int i1 = F1.lowRankBlocks[k1].second.i;
+ int j1 = F1.lowRankBlocks[k1].second.j;
+
+ int i2 = F2.lowRankBlocks[k2].second.i;
+ int j2 = F2.lowRankBlocks[k2].second.j;
+
+ const vector<Real> v = F1.lowRankBlocks[k1].second.vec;
+ const vector<Real> u = F2.lowRankBlocks[k2].second.vec;
+
+ total += (X.blocks[b1].blockBilinearForm(j2, i1, u, v) *
+ ZInv.blocks[b1].blockBilinearForm(j1, i2, v, u));
+
+ }
+ }
+ }
+ return total;
+
+}
+
+int main(int argc, char** argv) {
+
+ Real x = 1;
+ Real y = 2;
+ DenseMatrix m(2);
+ DenseMatrix n(2);
+ m.choleskyDecomposition(n);
+ vector<int> sizes;
+ sizes.push_back(3);
+ BlockDenseMatrix b(vector<Real>(0), sizes);
+
+ cout << x+y << endl;
+ for (int i = 0; i < m.dim; i++) {
+ for (int j = 0; j < m.dim; j++) {
+ cout << b.blocks[0].elem(i,j) << endl;
+ }
+ }
+
+}
diff --git a/mpack/Mlsame.cpp b/mpack/Mlsame.cpp
new file mode 100644
index 0000000..bc8f500
--- /dev/null
+++ b/mpack/Mlsame.cpp
@@ -0,0 +1,80 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..8e483c0
--- /dev/null
+++ b/mpack/Mutils.cpp
@@ -0,0 +1,174 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..b0e0afc
--- /dev/null
+++ b/mpack/Mxerbla.cpp
@@ -0,0 +1,49 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..52a9a64
--- /dev/null
+++ b/mpack/Raxpy.cpp
@@ -0,0 +1,99 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..5609a6c
--- /dev/null
+++ b/mpack/Rcopy.cpp
@@ -0,0 +1,95 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..a6e58f9
--- /dev/null
+++ b/mpack/Rdot.cpp
@@ -0,0 +1,99 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..657381a
--- /dev/null
+++ b/mpack/Rgemm.cpp
@@ -0,0 +1,231 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..9943b3e
--- /dev/null
+++ b/mpack/Rgemv.cpp
@@ -0,0 +1,177 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..b2bc419
--- /dev/null
+++ b/mpack/Rger.cpp
@@ -0,0 +1,130 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..eb26ad9
--- /dev/null
+++ b/mpack/Rlae2.cpp
@@ -0,0 +1,110 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..2cc92fe
--- /dev/null
+++ b/mpack/Rlaev2.cpp
@@ -0,0 +1,159 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..36b334e
--- /dev/null
+++ b/mpack/Rlamch.cpp
@@ -0,0 +1,235 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..53b3e64
--- /dev/null
+++ b/mpack/Rlanst.cpp
@@ -0,0 +1,121 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..10d33f7
--- /dev/null
+++ b/mpack/Rlansy.cpp
@@ -0,0 +1,149 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..dbbfa63
--- /dev/null
+++ b/mpack/Rlapy2.cpp
@@ -0,0 +1,90 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..e6a5fdd
--- /dev/null
+++ b/mpack/Rlarf.cpp
@@ -0,0 +1,94 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..337043d
--- /dev/null
+++ b/mpack/Rlarfb.cpp
@@ -0,0 +1,393 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..cd35142
--- /dev/null
+++ b/mpack/Rlarfg.cpp
@@ -0,0 +1,121 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..84f19f0
--- /dev/null
+++ b/mpack/Rlarft.cpp
@@ -0,0 +1,149 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..d5459e8
--- /dev/null
+++ b/mpack/Rlartg.cpp
@@ -0,0 +1,155 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..f178995
--- /dev/null
+++ b/mpack/Rlascl.cpp
@@ -0,0 +1,216 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..15091ec
--- /dev/null
+++ b/mpack/Rlaset.cpp
@@ -0,0 +1,105 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..890a00a
--- /dev/null
+++ b/mpack/Rlasr.cpp
@@ -0,0 +1,289 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..f2cd50e
--- /dev/null
+++ b/mpack/Rlasrt.cpp
@@ -0,0 +1,79 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..0562192
--- /dev/null
+++ b/mpack/Rlassq.cpp
@@ -0,0 +1,95 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..cd2907d
--- /dev/null
+++ b/mpack/Rlatrd.cpp
@@ -0,0 +1,167 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..87a3656
--- /dev/null
+++ b/mpack/Rnrm2.cpp
@@ -0,0 +1,102 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..b93127f
--- /dev/null
+++ b/mpack/Rorg2l.cpp
@@ -0,0 +1,117 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..4db20b6
--- /dev/null
+++ b/mpack/Rorg2r.cpp
@@ -0,0 +1,120 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..d041fdb
--- /dev/null
+++ b/mpack/Rorgql.cpp
@@ -0,0 +1,177 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..2da89b9
--- /dev/null
+++ b/mpack/Rorgqr.cpp
@@ -0,0 +1,177 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..68130a7
--- /dev/null
+++ b/mpack/Rorgtr.cpp
@@ -0,0 +1,157 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..188eabb
--- /dev/null
+++ b/mpack/Rpotf2.cpp
@@ -0,0 +1,139 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..c725ee0
--- /dev/null
+++ b/mpack/Rpotrf.cpp
@@ -0,0 +1,156 @@
+/*************************************************************************
+ *
+ * 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/Rscal.cpp b/mpack/Rscal.cpp
new file mode 100644
index 0000000..01ba1b4
--- /dev/null
+++ b/mpack/Rscal.cpp
@@ -0,0 +1,86 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..16fe0f6
--- /dev/null
+++ b/mpack/Rsteqr.cpp
@@ -0,0 +1,423 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..cf1e633
--- /dev/null
+++ b/mpack/Rsterf.cpp
@@ -0,0 +1,339 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..25c4b72
--- /dev/null
+++ b/mpack/Rswap.cpp
@@ -0,0 +1,98 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..81311e8
--- /dev/null
+++ b/mpack/Rsyev.cpp
@@ -0,0 +1,180 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..a45467e
--- /dev/null
+++ b/mpack/Rsymv.cpp
@@ -0,0 +1,183 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..e3fbb48
--- /dev/null
+++ b/mpack/Rsyr2.cpp
@@ -0,0 +1,156 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..af4c5b4
--- /dev/null
+++ b/mpack/Rsyr2k.cpp
@@ -0,0 +1,246 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..5ada114
--- /dev/null
+++ b/mpack/Rsyrk.cpp
@@ -0,0 +1,230 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..c0b7160
--- /dev/null
+++ b/mpack/Rsytd2.cpp
@@ -0,0 +1,151 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..af6fe3d
--- /dev/null
+++ b/mpack/Rsytrd.cpp
@@ -0,0 +1,187 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..321206d
--- /dev/null
+++ b/mpack/Rtrmm.cpp
@@ -0,0 +1,283 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..484766e
--- /dev/null
+++ b/mpack/Rtrmv.cpp
@@ -0,0 +1,189 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..74489ce
--- /dev/null
+++ b/mpack/Rtrsm.cpp
@@ -0,0 +1,310 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..ff2de21
--- /dev/null
+++ b/mpack/Rtrsv.cpp
@@ -0,0 +1,187 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..ca2545d
--- /dev/null
+++ b/mpack/iMlaenv.cpp
@@ -0,0 +1,291 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..87863de
--- /dev/null
+++ b/mpack/mblas_gmp.h
@@ -0,0 +1,94 @@
+/*************************************************************************
+ *
+ * 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 */
+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
new file mode 100644
index 0000000..4f98cd9
--- /dev/null
+++ b/mpack/mlapack_gmp.h
@@ -0,0 +1,92 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..1acc121
--- /dev/null
+++ b/mpack/mpack_config.h
@@ -0,0 +1,72 @@
+/*************************************************************************
+ *
+ * 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
new file mode 100644
index 0000000..809565b
--- /dev/null
+++ b/mpack/mutils_gmp.h
@@ -0,0 +1,76 @@
+/*************************************************************************
+ *
+ * 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
diff --git a/types.h b/types.h
new file mode 100644
index 0000000..d3a3d04
--- /dev/null
+++ b/types.h
@@ -0,0 +1,10 @@
+#ifndef SDP_BOOTSTRAP_TYPES_H_
+#define SDP_BOOTSTRAP_TYPES_H_
+
+#include <mblas_gmp.h>
+#include <mlapack_gmp.h>
+
+typedef mpz_class Integer;
+typedef mpf_class Real;
+
+#endif // SDP_BOOTSTRAP_TYPES_H_
--
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