[sdpb] 66/233: Switched to local version of mpack again because of openmp weirdness; some rearranging of files and editing of Makefile
Tobias Hansen
thansen at moszumanska.debian.org
Thu Mar 9 04:06:19 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 54b1ef7b48c543e21bf39f6895b7d80ced974bd5
Author: David Simmons-Duffin <dsd at neptune.sns.ias.edu>
Date: Mon Aug 11 00:33:18 2014 -0400
Switched to local version of mpack again because of openmp weirdness; some rearranging of files and editing of Makefile
---
.gitignore | 1 +
Makefile | 28 +-
mpack/Mlsame.cpp | 83 ++++
mpack/Mutils.cpp | 173 +++++++
mpack/Mxerbla.cpp | 42 ++
mpack/Raxpy.cpp | 97 ++++
mpack/Rcopy.cpp | 95 ++++
mpack/Rdot.cpp | 97 ++++
mpack/Rgemm.cpp | 223 +++++++++
mpack/Rgemv.cpp | 175 +++++++
mpack/Rger.cpp | 129 ++++++
mpack/Rgetf2.cpp | 124 +++++
mpack/Rgetrf.cpp | 128 ++++++
mpack/Rgetrs.cpp | 116 +++++
mpack/Rlae2.cpp | 110 +++++
mpack/Rlaev2.cpp | 156 +++++++
mpack/Rlamch.cpp | 969 +++++++++++++++++++++++++++++++++++++++
mpack/Rlanst.cpp | 113 +++++
mpack/Rlansy.cpp | 150 ++++++
mpack/Rlapy2.cpp | 90 ++++
mpack/Rlarf.cpp | 92 ++++
mpack/Rlarfb.cpp | 341 ++++++++++++++
mpack/Rlarfg.cpp | 121 +++++
mpack/Rlarft.cpp | 136 ++++++
mpack/Rlartg.cpp | 148 ++++++
mpack/Rlascl.cpp | 212 +++++++++
mpack/Rlaset.cpp | 104 +++++
mpack/Rlasr.cpp | 269 +++++++++++
mpack/Rlasrt.cpp | 77 ++++
mpack/Rlassq.cpp | 92 ++++
mpack/Rlaswp.cpp | 103 +++++
mpack/Rlatrd.cpp | 136 ++++++
mpack/Rnrm2.cpp | 104 +++++
mpack/Rorg2l.cpp | 114 +++++
mpack/Rorg2r.cpp | 117 +++++
mpack/Rorgql.cpp | 168 +++++++
mpack/Rorgqr.cpp | 165 +++++++
mpack/Rorgtr.cpp | 151 ++++++
mpack/Rpotf2.cpp | 134 ++++++
mpack/Rpotrf.cpp | 144 ++++++
mpack/Rrot.cpp | 99 ++++
mpack/Rrotg.cpp | 103 +++++
mpack/Rscal.cpp | 88 ++++
mpack/Rsteqr.cpp | 413 +++++++++++++++++
mpack/Rsterf.cpp | 338 ++++++++++++++
mpack/Rswap.cpp | 99 ++++
mpack/Rsyev.cpp | 168 +++++++
mpack/Rsymv.cpp | 179 ++++++++
mpack/Rsyr2.cpp | 152 ++++++
mpack/Rsyr2k.cpp | 236 ++++++++++
mpack/Rsyrk.cpp | 226 +++++++++
mpack/Rsytd2.cpp | 145 ++++++
mpack/Rsytrd.cpp | 178 +++++++
mpack/Rtrmm.cpp | 273 +++++++++++
mpack/Rtrmv.cpp | 186 ++++++++
mpack/Rtrsm.cpp | 296 ++++++++++++
mpack/Rtrsv.cpp | 185 ++++++++
mpack/iMlaenv.cpp | 283 ++++++++++++
mpack/iRamax.cpp | 98 ++++
mpack/mblas.h | 91 ++++
mpack/mblas_gmp.h | 96 ++++
mpack/mlapack.h | 107 +++++
mpack/mlapack_gmp.h | 96 ++++
mpack/mpack_config.h | 72 +++
mpack/mutils_gmp.h | 76 +++
main.cpp => src/main.cpp | 72 +--
tinyxml2.cpp => src/tinyxml2.cpp | 0
tinyxml2.h => src/tinyxml2.h | 0
types.h => src/types.h | 4 +-
69 files changed, 10343 insertions(+), 43 deletions(-)
diff --git a/.gitignore b/.gitignore
index 36392d5..e709d94 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,5 @@
# Object files
+obj
*.o
*.lo
diff --git a/Makefile b/Makefile
index c9f1e27..d72dd7d 100755
--- a/Makefile
+++ b/Makefile
@@ -1,21 +1,31 @@
-OBJECTS = main.o tinyxml2.o
-HEADERS = types.h tinyxml2.h
-SOURCES = $(OJBECTS:.o=.cpp)
+SOURCES := $(wildcard src/*.cpp) $(wildcard mpack/*.cpp)
+HEADERS := $(wildcard src/*.h) $(wildcard mpack/*.h)
+OBJECTS := $(patsubst %.cpp,obj/%.o,$(SOURCES))
RESULT = sdp-bootstrap
CC = g++
-CFLAGS = -g -O2 -Wall -ansi -L/home/dsd/lib -I/home/dsd/include/mpack -I/home/dsd/include -I/home/dsd/include/boost -fopenmp
+CFLAGS = -g -O2 -Wall -ansi -L/home/dsd/lib -I./mpack -I/home/dsd/include -I/home/dsd/include/boost -fopenmp -D___MPACK_BUILD_WITH_GMP___
RM = rm -f
.SUFFIXES: .cpp .o
$(RESULT): $(OBJECTS)
- $(CC) $(CFLAGS) -lgomp -lmblas_gmp -lmlapack_gmp -lgmp -lgmpxx -lmpc -lboost_serialization -lboost_system -lboost_filesystem -lboost_timer -o $@ $(OBJECTS)
+ $(CC) $(CFLAGS) -lgomp -lmblas_gmp -lmlapack_gmp -lgmp -lgmpxx -lmpc -lboost_serialization -lboost_system -lboost_filesystem -lboost_timer -lboost_program_options -o $@ $^
-.cpp.o:
- $(CC) $(CFLAGS) -c $< -o $@
+obj/%.o: %.cpp
+ g++ $(CFLAGS) -c -o $@ $<
clean:
- $(RM) *.o *.core core *~ src/*.o math/*.o
+ $(RM) -r obj
-$(OBJECTS): $(HEADERS)
+obj:
+ @mkdir -p $@/src
+ @mkdir -p $@/mpack
+
+foo:
+ echo $(OBJECTS)
+
+$(OBJECTS): $(HEADERS) | obj
+
+CFLAGS += -MMD
+-include $(OBJECTS:.o=.d)
diff --git a/mpack/Mlsame.cpp b/mpack/Mlsame.cpp
new file mode 100644
index 0000000..9981ab6
--- /dev/null
+++ b/mpack/Mlsame.cpp
@@ -0,0 +1,83 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Mlsame.cpp,v 1.4 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Mlsame.cpp,v 1.4 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/lsame.f
+Mlsame returns 1 if CA is the same letter as CB regardless of case.
+*/
+
+#include <mblas.h>
+#include <ctype.h>
+
+INTEGER Mlsame(const char *a, const char *b)
+{
+ if (toupper(*a) == toupper(*b))
+ return (INTEGER) 1;
+ return (INTEGER) 0;
+}
diff --git a/mpack/Mutils.cpp b/mpack/Mutils.cpp
new file mode 100644
index 0000000..d972e78
--- /dev/null
+++ b/mpack/Mutils.cpp
@@ -0,0 +1,173 @@
+/*************************************************************************
+ *
+ * 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>
+
+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..5636eed
--- /dev/null
+++ b/mpack/Mxerbla.cpp
@@ -0,0 +1,42 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Mxerbla.cpp,v 1.7 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Based on http://www.netlib.org/blas/xerbla.f
+Mxerbla is an error handler for the Mlapack routines.
+*/
+
+#include <stdio.h>
+#include <mblas.h>
+
+void Mxerbla(const char *srname, int info)
+{
+ fprintf(stderr, " ** On entry to %s parameter number %2d had an illegal value\n", srname, info);
+ exit(info);
+}
diff --git a/mpack/Raxpy.cpp b/mpack/Raxpy.cpp
new file mode 100644
index 0000000..4a7e0d6
--- /dev/null
+++ b/mpack/Raxpy.cpp
@@ -0,0 +1,97 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Raxpy.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Raxpy.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/daxpy.f
+*/
+
+#include <mblas.h>
+
+void Raxpy(INTEGER n, REAL da, REAL * dx, INTEGER incx, REAL * dy, INTEGER incy)
+{
+ INTEGER i, ix = 0, iy = 0;
+ REAL Zero = 0.0;
+
+ if (n <= 0)
+ return;
+ if (da == Zero)
+ return;
+
+ if (incx < 0)
+ ix = (-n + 1) * incx;
+ if (incy < 0)
+ iy = (-n + 1) * incy;
+
+ for (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..9f75bd4
--- /dev/null
+++ b/mpack/Rcopy.cpp
@@ -0,0 +1,95 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rcopy.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rcopy.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/dcopy.f
+Rcopy copies a vector, x, to a vector, y.
+*/
+
+#include <mblas.h>
+
+void Rcopy(INTEGER n, REAL * dx, INTEGER incx, REAL * dy, INTEGER incy)
+{
+ INTEGER i, ix = 0, iy = 0;
+
+ if (n <= 0)
+ return;
+
+ if (incx < 0)
+ ix = (-n + 1) * incx;
+ if (incy < 0)
+ iy = (-n + 1) * incy;
+
+ for (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..b561c4c
--- /dev/null
+++ b/mpack/Rdot.cpp
@@ -0,0 +1,97 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rdot.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rdot.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/ddot.f
+Rdot forms the dot product of two vectors.
+*/
+
+#include <mblas.h>
+
+REAL Rdot(INTEGER n, REAL * dx, INTEGER incx, REAL * dy, INTEGER incy)
+{
+ INTEGER i, ix = 0, iy = 0;
+ REAL temp;
+
+ temp = 0.0;
+ if (n <= 0)
+ return temp;
+
+ if (incx < 0)
+ ix = (-n + 1) * incx;
+ if (incy < 0)
+ iy = (-n + 1) * incy;
+
+ for (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..4742419
--- /dev/null
+++ b/mpack/Rgemm.cpp
@@ -0,0 +1,223 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rgemm.cpp,v 1.7 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rgemm.cpp,v 1.7 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rgemm(const char *transa, const char *transb, INTEGER m, INTEGER n, INTEGER k, REAL alpha, REAL * A, INTEGER lda, REAL * B,
+ INTEGER ldb, REAL beta, REAL * C, INTEGER ldc)
+{
+ INTEGER i, j, l, nota, notb, nrowa, ncola, nrowb, info;
+ REAL temp;
+ REAL Zero = 0.0, One = 1.0;
+
+ nota = Mlsame(transa, "N");
+ notb = Mlsame(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(transa, "C")) && (!Mlsame(transa, "T")))
+ info = 1;
+ else if (!notb && (!Mlsame(transb, "C")) && (!Mlsame(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((INTEGER) 1, nrowa))
+ info = 8;
+ else if (ldb < max((INTEGER) 1, nrowb))
+ info = 10;
+ else if (ldc < max((INTEGER) 1, m))
+ info = 13;
+ if (info != 0) {
+ Mxerbla("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 (j = 0; j < n; j++) {
+ for (i = 0; i < m; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ for (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 (j = 0; j < n; j++) {
+ if (beta == Zero) {
+ for (i = 0; i < m; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ } else if (beta != One) {
+ for (i = 0; i < m; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ for (l = 0; l < k; l++) {
+ if (B[l + j * ldb] != Zero) {
+ temp = alpha * B[l + j * ldb];
+ for (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 (j = 0; j < n; j++) {
+ for (i = 0; i < m; i++) {
+ temp = Zero;
+ for (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 (j = 0; j < n; j++) {
+ if (beta == Zero) {
+ for (i = 0; i < m; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ } else if (beta != One) {
+ for (i = 0; i < m; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ for (l = 0; l < k; l++) {
+ if (B[j + l * ldb] != Zero) {
+ temp = alpha * B[j + l * ldb];
+ for (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 (j = 0; j < n; j++) {
+ for (i = 0; i < m; i++) {
+ temp = Zero;
+ for (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..b2b6ec7
--- /dev/null
+++ b/mpack/Rgemv.cpp
@@ -0,0 +1,175 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rgemv.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rgemv.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rgemv(const char *trans, INTEGER m, INTEGER n, REAL alpha, REAL * A, INTEGER lda, REAL * x, INTEGER incx, REAL beta, REAL * y,
+ INTEGER incy)
+{
+ INTEGER lenx, leny, i, ix, jx, kx, iy, j, jy, ky;
+ INTEGER info = 0;
+ REAL Zero = 0.0, One = 1.0;
+ REAL temp;
+
+//Test the input parameters.
+ if (!Mlsame(trans, "N") && !Mlsame(trans, "T") && !Mlsame(trans, "C"))
+ info = 1;
+ else if (m < 0)
+ info = 2;
+ else if (n < 0)
+ info = 3;
+ else if (lda < max((INTEGER) 1, m))
+ info = 6;
+ else if (incx == 0)
+ info = 8;
+ else if (incy == 0)
+ info = 11;
+ if (info != 0) {
+ Mxerbla("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(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 (i = 0; i < leny; i++) {
+ y[iy] = Zero;
+ iy = iy + incy;
+ }
+ } else {
+ for (i = 0; i < leny; i++) {
+ y[iy] = beta * y[iy];
+ iy = iy + incy;
+ }
+ }
+ }
+ if (alpha == Zero)
+ return;
+ if (Mlsame(trans, "N")) {
+//form y := alpha*A*x + y.
+ jx = kx;
+ for (j = 0; j < n; j++) {
+ if (x[jx] != Zero) {
+ temp = alpha * x[jx];
+ iy = ky;
+ for (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 (j = 0; j < n; j++) {
+ temp = Zero;
+ ix = kx;
+ for (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..eee2ad0
--- /dev/null
+++ b/mpack/Rger.cpp
@@ -0,0 +1,129 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rger.cpp,v 1.7 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rger.cpp,v 1.7 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rger(INTEGER m, INTEGER n, REAL alpha, REAL * x, INTEGER incx, REAL * y, INTEGER incy, REAL * A, INTEGER lda)
+{
+ INTEGER i, ix, kx, j, jy, info = 0;
+ REAL Zero = 0.0;
+ REAL temp;
+
+//Test the input parameters.
+ 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((INTEGER) 1, m))
+ info = 9;
+ if (info != 0) {
+ Mxerbla("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 (j = 0; j < n; j++) {
+ if (y[jy] != Zero) {
+ temp = alpha * y[jy];
+ ix = kx;
+ for (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/Rgetf2.cpp b/mpack/Rgetf2.cpp
new file mode 100644
index 0000000..30a9525
--- /dev/null
+++ b/mpack/Rgetf2.cpp
@@ -0,0 +1,124 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rgetf2.cpp,v 1.11 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rgetf2(INTEGER m, INTEGER n, REAL * A, INTEGER lda, INTEGER * ipiv, INTEGER * info)
+{
+ INTEGER i, j, jp;
+ REAL sfmin;
+ REAL Zero = 0.0, One = 1.0;
+
+//Test the input parameters.
+ *info = 0;
+ if (m < 0) {
+ *info = -1;
+ } else if (n < 0) {
+ *info = -2;
+ } else if (lda < max((INTEGER) 1, m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ Mxerbla("Rgetf2", -(*info));
+ return;
+ }
+//Quick return if possible
+ if (m == 0 || n == 0) {
+ return;
+ }
+//Compute machine safe minimum
+ sfmin = Rlamch("S");
+ for (j = 1; j <= min(m, n); j++) {
+//Find pivot and test for singularity.
+ jp = j - 1 + iRamax(m - j + 1, &A[(j - 1) + (j - 1) * lda], 1);
+ ipiv[j - 1] = jp;
+ if (A[(jp - 1) + (j - 1) * lda] != Zero) {
+//Apply the interchange to columns 1:N.
+ if (jp != j) {
+ Rswap(n, &A[(j - 1) + 0 * lda], lda, &A[(jp - 1) + 0 * lda], lda);
+ }
+//Compute elements J+1:M of J-th column.
+ if (j < m) {
+ if (abs(A[(j - 1) + (j - 1) * lda]) >= sfmin) {
+ Rscal(m - j, One / A[(j - 1) + (j - 1) * lda], &A[j + (j - 1) * lda], 1);
+ } else {
+ for (i = 1; i <= m - j; i++) {
+ A[(j + i - 1) + (j - 1) * lda] = A[(j + i - 1) + (j - 1) * lda] / A[(j - 1) + (j - 1) * lda];
+ }
+ }
+ }
+ } else if (*info == 0) {
+ *info = j;
+ }
+ if (j < min(m, n)) {
+//Update trailing submatrix.
+ Rger(m - j, n - j, -One, &A[j + (j - 1) * lda], 1, &A[(j - 1) + j * lda], lda, &A[j + j * lda], lda);
+ }
+ }
+ return;
+}
diff --git a/mpack/Rgetrf.cpp b/mpack/Rgetrf.cpp
new file mode 100644
index 0000000..a359c90
--- /dev/null
+++ b/mpack/Rgetrf.cpp
@@ -0,0 +1,128 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rgetrf.cpp,v 1.11 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rgetrf(INTEGER m, INTEGER n, REAL * A, INTEGER lda, INTEGER * ipiv, INTEGER * info)
+{
+ INTEGER i, j, jb, nb, iinfo;
+ REAL One = 1.0;
+
+//Test the input parameters.
+ *info = 0;
+ if (m < 0) {
+ *info = -1;
+ } else if (n < 0) {
+ *info = -2;
+ } else if (lda < max((INTEGER) 1, m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ Mxerbla("Rgetrf", -(*info));
+ return;
+ }
+//Quick return if possible
+ if (m == 0 || n == 0) {
+ return;
+ }
+//Determine the block size for this environment.
+ nb = iMlaenv(1, "Rgetrf", " ", m, n, -1, -1);
+ if (nb <= 1 || nb >= min(m, n)) {
+//Use unblocked code.
+ Rgetf2(m, n, A, lda, ipiv, info);
+ } else {
+//Use blocked code.
+ for (j = 1; j <= min(m, n); j = j + nb) {
+ jb = min(min(m, n) - j + 1, nb);
+//Factor diagonal and subdiagonal blocks and test for exact
+//singularity.
+ Rgetf2(m - j + 1, jb, &A[(j - 1) + (j - 1) * lda], lda, &ipiv[j - 1], &iinfo);
+//Adjust INFO and the pivot indices.
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+ for (i = j; i <= min(m, j + jb - 1); i++) {
+ ipiv[i - 1] = j - 1 + ipiv[i - 1];
+ }
+//Apply interchanges to columns 1:J-one
+ Rlaswp(j - 1, A, lda, j, j + jb - 1, ipiv, 1);
+ if (j + jb <= n) {
+//Apply interchanges to columns J+JB:N.
+ Rlaswp(n - j - jb + 1, &A[0 + (j + jb - 1) * lda], lda, j, j + jb - 1, ipiv, 1);
+//Compute block row of U.
+ Rtrsm("Left", "Lower", "No transpose", "Unit", jb, n - j - jb + 1, One, &A[(j - 1) + (j - 1) * lda], lda, &A[(j - 1) + (j + jb - 1) * lda], lda);
+ if (j + jb <= m) {
+//Update trailing submatrix.
+ Rgemm("No transpose", "No transpose", m - j - jb + 1,
+ n - j - jb + 1, jb, -One, &A[(j + jb - 1) + (j - 1) * lda], lda, &A[(j - 1) + (j + jb - 1) * lda], lda, One, &A[(j + jb - 1) + (j + jb - 1) * lda], lda);
+ }
+ }
+ }
+ }
+ return;
+}
diff --git a/mpack/Rgetrs.cpp b/mpack/Rgetrs.cpp
new file mode 100644
index 0000000..c684aa7
--- /dev/null
+++ b/mpack/Rgetrs.cpp
@@ -0,0 +1,116 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rgetrs.cpp,v 1.11 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+
+void Rgetrs(const char *trans, INTEGER n, INTEGER nrhs, REAL * A, INTEGER lda, INTEGER * ipiv, REAL * B, INTEGER ldb, INTEGER * info)
+{
+ INTEGER notran;
+ REAL One = 1.0;
+
+ *info = 0;
+ notran = Mlsame(trans, "N");
+ if (!notran && !Mlsame(trans, "T") && !Mlsame(trans, "C")) {
+ *info = -1;
+ } else if (n < 0) {
+ *info = -2;
+ } else if (nrhs < 0) {
+ *info = -3;
+ } else if (lda < max((INTEGER) 1, n)) {
+ *info = -5;
+ } else if (ldb < max((INTEGER) 1, n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ Mxerbla("Rgetrs", -(*info));
+ return;
+ }
+//Quick return if possible
+ if (n == 0 || nrhs == 0) {
+ return;
+ }
+ if (notran) {
+//Solve A * X = B.
+//Apply row interchanges to the right hand sides.
+ Rlaswp(nrhs, B, ldb, 1, n, ipiv, 1);
+//Solve L*X = B, overwriting B with X.
+ Rtrsm("Left", "Lower", "No transpose", "Unit", n, nrhs, One, A, lda, B, ldb);
+//Solve U*X = B, overwriting B with X.
+ Rtrsm("Left", "Upper", "No transpose", "Non-unit", n, nrhs, One, A, lda, B, ldb);
+ } else {
+//Solve A' * X = B.
+//Solve U'*X = B, overwriting B with X.
+ Rtrsm("Left", "Upper", "Transpose", "Non-unit", n, nrhs, One, A, lda, B, ldb);
+//Solve L'*X = B, overwriting B with X.
+ Rtrsm("Left", "Lower", "Transpose", "Unit", n, nrhs, One, A, lda, B, ldb);
+//Apply row interchanges to the solution vectors.
+ Rlaswp(nrhs, B, ldb, 1, n, ipiv, -1);
+ }
+ return;
+}
diff --git a/mpack/Rlae2.cpp b/mpack/Rlae2.cpp
new file mode 100644
index 0000000..fcda00b
--- /dev/null
+++ b/mpack/Rlae2.cpp
@@ -0,0 +1,110 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlae2.cpp,v 1.4 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rlae2(REAL a, REAL b, REAL c, REAL * rt1, REAL * rt2)
+{
+ REAL sm, df, adf, tb, ab;
+ REAL acmx, acmn, rt;
+ REAL 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..f6afdde
--- /dev/null
+++ b/mpack/Rlaev2.cpp
@@ -0,0 +1,156 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlaev2.cpp,v 1.6 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+#include <stdio.h> //for printf. shall be removed
+
+void Rlaev2(REAL a, REAL b, REAL c, REAL * rt1, REAL * rt2, REAL * cs1, REAL * sn1)
+{
+ REAL ab, acmn, acmx, acs, adf;
+ REAL cs, ct, df, rt, sm, tb, tn;
+ REAL zero, one, two, half;
+ INTEGER 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 {
+ 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..03919ef
--- /dev/null
+++ b/mpack/Rlamch.cpp
@@ -0,0 +1,969 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlamch.cpp,v 1.16 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+#include <mblas.h>
+#include <mlapack.h>
+
+#if defined ___MPACK_BUILD_WITH_DOUBLE___
+#include <float.h>
+#endif
+
+#if defined ___MPACK_BUILD_WITH___FLOAT128___
+#include <quadmath.h>
+#endif
+
+#include <stdio.h>
+
+#if defined ___MPACK_BUILD_WITH_MPFR___
+//"E" denots we always calculate relative machine precision (e).
+//where 1+e = 1, minimum of e.
+REAL RlamchE_mpfr(void)
+{
+ static REAL eps;
+ static int called = 0;
+
+ if (called)
+ return eps;
+
+ REAL one = 1.0, rtmp;
+ mp_prec_t prec;
+ prec = one.get_prec();
+ rtmp = exp2(prec);
+ eps = one / rtmp;
+ 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
+REAL RlamchS_mpfr(void)
+{
+ static REAL safemin;
+ static int called = 0;
+
+ if (called)
+ return safemin;
+
+ REAL one = 1.0, rtmp;
+ mp_exp_t emin;
+ emin = one.get_emin() + 1;
+ safemin = div_2ui(one, -emin);
+ return safemin;
+}
+
+//"B" base = base of the machine
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchB_mpfr(void)
+{
+ REAL two;
+ two = 2.0;
+ return two;
+}
+
+//"P" prec = eps*base
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchP_mpfr(void)
+{
+ REAL base, eps, prec;
+
+ base = RlamchB_mpfr();
+ eps = RlamchE_mpfr();
+ prec = eps * base;
+ return prec;
+}
+
+//"N" t = number of digits in mantissa
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchN_mpfr(void)
+{
+ REAL r;
+ mp_prec_t p = r.get_default_prec();
+ return REAL(p);
+}
+
+//"R" rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchR_mpfr(void)
+{
+//always rounding in addition on MPFR.
+ REAL mtmp;
+ mtmp = 1.0;
+ return mtmp;
+}
+
+//"M"
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchM_mpfr(void)
+{
+//Note: in MPFR, no gradual underflow, just happens suddenly.
+ REAL rtmp;
+ mpreal minexp (rtmp.get_emin());
+ return minexp;
+}
+
+//"U"
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchU_mpfr(void)
+{
+ static REAL safemin;
+ static int called = 0;
+
+ if (called)
+ return safemin;
+
+ REAL one = 1.0, rtmp;
+ mp_exp_t emin;
+ emin = one.get_emin();
+ safemin = div_2si(one, - emin - 1);
+ return safemin;
+}
+
+//"L"
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchL_mpfr(void)
+{
+ mpreal dummy;
+ mp_exp_t emax;
+ emax = dummy.get_emax() - 1;
+ return mpreal(emax);
+}
+
+//"O"
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchO_mpfr(void)
+{
+///(1-2^(-p))*2^emax
+//in double's case, +1.7976931348623157e+308 = +4.4942328371557898e+307 x 3.999999999999999(16 digits)
+//where +4.4942328371557898e+307 is the reciprocal of 1/safmin.
+//of course +4.4942328371557898e+307 times 4 overflows.
+
+ static REAL overflow;
+ static int called = 0;
+
+ if (called)
+ return overflow;
+
+ REAL one = 1.0, rtmp;
+ mp_prec_t prec = one.get_prec();
+ mp_exp_t emax = one.get_emax();
+ rtmp = exp2(-(long) prec);
+ overflow = mul_2si(one, emax - 1);
+ overflow = overflow * (1.0 - rtmp) * 2.0;
+ return overflow;
+}
+
+//"Z" :dummy
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchZ_mpfr(void)
+{
+ REAL mtemp = 0.0;
+ return mtemp;
+}
+
+REAL Rlamch_mpfr(const char *cmach)
+{
+ if (Mlsame(cmach, "E"))
+ return RlamchE_mpfr();
+ if (Mlsame(cmach, "S"))
+ return RlamchS_mpfr();
+ if (Mlsame(cmach, "B"))
+ return RlamchB_mpfr();
+ if (Mlsame(cmach, "P"))
+ return RlamchP_mpfr();
+ if (Mlsame(cmach, "N"))
+ return RlamchN_mpfr();
+ if (Mlsame(cmach, "R"))
+ return RlamchR_mpfr();
+ if (Mlsame(cmach, "M"))
+ return RlamchM_mpfr();
+ if (Mlsame(cmach, "U"))
+ return RlamchU_mpfr();
+ if (Mlsame(cmach, "L"))
+ return RlamchL_mpfr();
+ if (Mlsame(cmach, "O"))
+ return RlamchO_mpfr();
+
+ Mxerbla("Rlamch", 1);
+ return RlamchZ_mpfr();
+}
+#endif
+
+#if defined ___MPACK_BUILD_WITH_GMP___
+//"E" denots we always calculate relative machine precision (e).
+//where 1+e = 1, minimum of e.
+REAL RlamchE_gmp(void)
+{
+ static REAL eps;
+ static int called = 0;
+ if (called)
+ return eps;
+ REAL 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
+REAL RlamchS_gmp(void)
+{
+ REAL sfmin;
+ REAL 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
+ REAL 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
+REAL RlamchB_gmp(void)
+{
+ REAL two;
+ two = 2.0;
+ return two;
+}
+
+//"P" prec = eps*base
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchP_gmp(void)
+{
+ REAL 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
+REAL RlamchN_gmp(void)
+{
+ unsigned long int tmp;
+ REAL mtmp;
+ REAL 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);
+ REAL 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
+REAL RlamchR_gmp(void)
+{
+//always rounding in addition on GMP.
+ REAL mtmp;
+
+ mtmp = 1.0;
+ return mtmp;
+}
+
+//"M"
+//cf.http://www.netlib.org/blas/dlamch.f
+REAL RlamchM_gmp(void)
+{
+ unsigned long exp2;
+ REAL tmp;
+ REAL 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
+ REAL 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
+REAL RlamchU_gmp(void)
+{
+ REAL underflowmin;
+ REAL 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
+REAL RlamchL_gmp(void)
+{
+ REAL 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
+REAL RlamchO_gmp(void)
+{
+ REAL overflowmax;
+ REAL 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
+REAL RlamchZ_gmp(void)
+{
+ REAL mtemp = 0.0;
+ return mtemp;
+}
+
+REAL Rlamch_gmp(const char *cmach)
+{
+ if (Mlsame(cmach, "E"))
+ return RlamchE_gmp();
+ if (Mlsame(cmach, "S"))
+ return RlamchS_gmp();
+ if (Mlsame(cmach, "B"))
+ return RlamchB_gmp();
+ if (Mlsame(cmach, "P"))
+ return RlamchP_gmp();
+ if (Mlsame(cmach, "N"))
+ return RlamchN_gmp();
+ if (Mlsame(cmach, "R"))
+ return RlamchR_gmp();
+ if (Mlsame(cmach, "M"))
+ return RlamchM_gmp();
+ if (Mlsame(cmach, "U"))
+ return RlamchU_gmp();
+ if (Mlsame(cmach, "L"))
+ return RlamchL_gmp();
+ if (Mlsame(cmach, "O"))
+ return RlamchO_gmp();
+
+ Mxerbla("Rlamch", 1);
+ return RlamchZ_gmp();
+}
+#endif
+
+#if defined ___MPACK_BUILD_WITH_QD___
+//"E" denots we always calculate relative machine precision (e).
+//where 1+e = 1, minimum of e.
+qd_real RlamchE_qd(void)
+{
+ //2^-209 = 1.21e-63
+ return qd_real::_eps;
+}
+
+//"S" denots we always calculate `safe minimum, such that 1/sfmin does not overflow'.
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchS_qd(void)
+{
+ //2^(-1022+3*53) = 1.626e-260
+ return qd_real::_min_normalized;
+}
+
+//"B" base = base of the machine
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchB_qd(void)
+{
+ qd_real two;
+ two = 2.0;
+ return two;
+}
+
+//"P" prec = eps*base
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchP_qd(void)
+{
+ qd_real base, eps, prec;
+
+ base = RlamchB_qd();
+ eps = RlamchE_qd();
+ prec = eps * base;
+ return prec;
+}
+
+//"N" t = number of digits in mantissa
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchN_qd(void)
+{
+ return (qd_real) 208.0; //52*4
+}
+
+//"R" rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchR_qd(void)
+{
+ qd_real mtmp;
+ mtmp = 1.0;
+ return mtmp;
+}
+
+//"M"
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchM_qd(void)
+{
+ return qd_real(-1022.0 + 3.0 * 53.0);
+}
+
+//"U"
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchU_qd(void)
+{
+ return qd_real::_min_normalized;
+}
+
+//"L"
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchL_qd(void)
+{
+ return (qd_real) 1024.0;
+}
+
+//"O"
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchO_qd(void)
+{
+ return qd_real::_max; //approx 1.7976931348623157E+308 in float.h
+}
+
+//"Z" :dummy
+//cf.http://www.netlib.org/blas/dlamch.f
+qd_real RlamchZ_qd(void)
+{
+ qd_real mtemp = 0.0;
+ return mtemp;
+}
+
+qd_real Rlamch_qd(const char *cmach)
+{
+ if (Mlsame(cmach, "E"))
+ return RlamchE_qd();
+ if (Mlsame(cmach, "S"))
+ return RlamchS_qd();
+ if (Mlsame(cmach, "B"))
+ return RlamchB_qd();
+ if (Mlsame(cmach, "P"))
+ return RlamchP_qd();
+ if (Mlsame(cmach, "N"))
+ return RlamchN_qd();
+ if (Mlsame(cmach, "R"))
+ return RlamchR_qd();
+ if (Mlsame(cmach, "M"))
+ return RlamchM_qd();
+ if (Mlsame(cmach, "U"))
+ return RlamchU_qd();
+ if (Mlsame(cmach, "L"))
+ return RlamchL_qd();
+ if (Mlsame(cmach, "O"))
+ return RlamchO_qd();
+
+ Mxerbla("Rlamch", 1);
+ return RlamchZ_qd();
+}
+#endif
+
+#if defined ___MPACK_BUILD_WITH_DD___
+//"E" denots we always calculate relative machine precision (e).
+//where 1+e = 1, minimum of e.
+dd_real RlamchE_dd(void)
+{
+ //2^(-52-52) = 2^-104 = 4.93e-32
+ return dd_real::_eps;
+}
+
+//"S" denots we always calculate `safe minimum, such that 1/sfmin does not overflow'.
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchS_dd(void)
+{
+ //2^(-1022+53) = 2.0042e-292
+ return dd_real::_min_normalized;
+}
+
+//"B" base = base of the machine
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchB_dd(void)
+{
+ dd_real two;
+ two = 2.0;
+ return two;
+}
+
+//"P" prec = eps*base
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchP_dd(void)
+{
+ dd_real base, eps, prec;
+
+ base = RlamchB_dd();
+ eps = RlamchE_dd();
+ prec = eps * base;
+ return prec;
+}
+
+//"N" t = number of digits in mantissa
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchN_dd(void)
+{
+ return (dd_real) 104.0; //52*2
+}
+
+//"R" rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchR_dd(void)
+{
+ dd_real mtmp;
+ mtmp = 1.0;
+ return mtmp;
+}
+
+//"M"
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchM_dd(void)
+{
+ return dd_real(-1022.0 + 53.0);
+}
+
+//"U"
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchU_dd(void)
+{
+ return dd_real::_min_normalized;
+}
+
+//"L"
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchL_dd(void)
+{
+ return (dd_real) 1024.0;
+}
+
+//"O"
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchO_dd(void)
+{
+ return dd_real::_max; //approx 1.7976931348623157E+308 in float.h
+}
+
+//"Z" :dummy
+//cf.http://www.netlib.org/blas/dlamch.f
+dd_real RlamchZ_dd(void)
+{
+ dd_real mtemp = 0.0;
+ return mtemp;
+}
+
+dd_real Rlamch_dd(const char *cmach)
+{
+ if (Mlsame(cmach, "E"))
+ return RlamchE_dd();
+ if (Mlsame(cmach, "S"))
+ return RlamchS_dd();
+ if (Mlsame(cmach, "B"))
+ return RlamchB_dd();
+ if (Mlsame(cmach, "P"))
+ return RlamchP_dd();
+ if (Mlsame(cmach, "N"))
+ return RlamchN_dd();
+ if (Mlsame(cmach, "R"))
+ return RlamchR_dd();
+ if (Mlsame(cmach, "M"))
+ return RlamchM_dd();
+ if (Mlsame(cmach, "U"))
+ return RlamchU_dd();
+ if (Mlsame(cmach, "L"))
+ return RlamchL_dd();
+ if (Mlsame(cmach, "O"))
+ return RlamchO_dd();
+
+ Mxerbla("Rlamch", 1);
+ return RlamchZ_dd();
+}
+#endif
+
+#if defined ___MPACK_BUILD_WITH_DOUBLE___
+//"E" denots we always calculate relative machine precision (e).
+//where 1+e = 1, minimum of e.
+double RlamchE_double(void)
+{
+ static double eps;
+ static int called = 0;
+ if (called)
+ return eps;
+ eps = 1.0;
+//We all know double is the IEEE 754 2008 binary64 format has 53bit significant digits
+ for (int i = 0; i < DBL_MANT_DIG; i++) {
+ eps = eps / 2.0;
+ }
+ 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
+double RlamchS_double(void)
+{
+ return DBL_MIN;
+
+//IEEE 754 2008 binary64: emin = -1022
+//2^{-1022} = 2.225073858507201e-308 = DBL_MIN in float.h
+ static double eps;
+ static int called = 0;
+ if (called)
+ return eps;
+ eps = 1.0;
+//We all know double is the IEEE 754 2008 binary64 format has 53bit significant digits
+ for (int i = 0; i < 1022; i++) {
+ eps = eps / 2.0;
+ }
+ called = 1;
+ return eps;
+}
+
+//"B" base = base of the machine
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchB_double(void)
+{
+ double two;
+ two = 2.0;
+ return two;
+}
+
+//"P" prec = eps*base
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchP_double(void)
+{
+ double base, eps, prec;
+
+ base = RlamchB_double();
+ eps = RlamchE_double();
+ prec = eps * base;
+ return prec;
+}
+
+//"N" t = number of digits in mantissa
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchN_double(void)
+{
+//IEEE 754 2008 binary64 has 53 (52+1) bit significant digits
+ return (double) DBL_MANT_DIG;
+}
+
+//"R" rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchR_double(void)
+{
+ double mtmp;
+ mtmp = 1.0;
+ return mtmp;
+}
+
+//"M"
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchM_double(void)
+{
+//the exponent of IEEE 754 2008 binary64 is -1022.
+//then -1022 + 1 = -1021.
+ return (double) DBL_MIN_EXP;
+}
+
+//"U"
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchU_double(void)
+{
+ return DBL_MIN;
+
+//2^{-1021-1} minimum exponent
+ static double eps;
+ static int called = 0;
+ if (called)
+ return eps;
+ eps = 1.0;
+//We all know double is the IEEE 754 2008 binary64 format has 53bit significant digits
+ for (int i = 0; i < 1022; i++) {
+ eps = eps / 2.0;
+ }
+ called = 1;
+ return eps;
+}
+
+//"L"
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchL_double(void)
+{
+//+1023 in IEEE 754 2008 binary64
+//then 1023 + 1 = 1024.
+ return DBL_MAX_EXP;
+}
+
+//"O"
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchO_double(void)
+{
+//1.7976931348623157E+308 in IEEE 754 2008 binary64.
+ return DBL_MAX;
+}
+
+//"Z" :dummy
+//cf.http://www.netlib.org/blas/dlamch.f
+double RlamchZ_double(void)
+{
+ double mtemp = 0.0;
+ return mtemp;
+}
+
+double Rlamch_double(const char *cmach)
+{
+ if (Mlsame(cmach, "E"))
+ return RlamchE_double();
+ if (Mlsame(cmach, "S"))
+ return RlamchS_double();
+ if (Mlsame(cmach, "B"))
+ return RlamchB_double();
+ if (Mlsame(cmach, "P"))
+ return RlamchP_double();
+ if (Mlsame(cmach, "N"))
+ return RlamchN_double();
+ if (Mlsame(cmach, "R"))
+ return RlamchR_double();
+ if (Mlsame(cmach, "M"))
+ return RlamchM_double();
+ if (Mlsame(cmach, "U"))
+ return RlamchU_double();
+ if (Mlsame(cmach, "L"))
+ return RlamchL_double();
+ if (Mlsame(cmach, "O"))
+ return RlamchO_double();
+ Mxerbla("Rlamch", 1);
+ return RlamchZ_double();
+}
+#endif
+
+#if defined ___MPACK_BUILD_WITH___FLOAT128___
+//"E" denots we always calculate relative machine precision (e).
+//where 1+e = 1, minimum of e.
+__float128 RlamchE___float128(void)
+{
+ return FLT128_EPSILON;
+}
+
+//"S" denots we always calculate `safe minimum, such that 1/sfmin does not overflow'.
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchS___float128(void)
+{
+ //IEEE 754 2008 binary128: emin = -16382
+ //2^{-16382} = 3.36210314311209350626267781732175260e-4932Q
+ return FLT128_MIN;
+
+ static __float128 eps;
+ static int called = 0;
+ if (called)
+ return eps;
+ eps = 1.0;
+//We all know double is the IEEE 754 2008 binary128 format has 113bit significant digits
+ for (int i = 0; i < 16383; i++) {
+ eps = eps / 2.0Q;
+ }
+ called = 1;
+}
+
+//"B" base = base of the machine
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchB___float128(void)
+{
+ __float128 two;
+ two = 2.0;
+ return two;
+}
+
+//"P" prec = eps*base
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchP___float128(void)
+{
+ __float128 base, eps, prec;
+
+ base = RlamchB___float128();
+ eps = RlamchE___float128();
+ prec = eps * base;
+ return prec;
+}
+
+//"N" t = number of digits in mantissa
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchN___float128(void)
+{
+ return (__float128) FLT128_MANT_DIG; //113
+}
+
+//"R" rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchR___float128(void)
+{
+ __float128 mtmp;
+ mtmp = 1.0;
+ return mtmp;
+}
+
+//"M"
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchM___float128(void)
+{
+//the exponent of IEEE 754 2008 binary64 is -16382.
+//then -16382 + 1 = -16381
+ return FLT128_MIN_EXP;
+}
+
+//"U"
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchU___float128(void)
+{
+ return FLT128_MIN;
+
+//2^{-16382+1} minimum exponent
+ static double eps;
+ static int called = 0;
+ if (called)
+ return eps;
+ eps = 1.0;
+//We all know double is the IEEE 754 2008 binary128 format has 113bit significant digits
+ for (int i = 0; i < 16382; i++) {
+ eps = eps / 2.0;
+ }
+ called = 1;
+ return eps;
+
+}
+
+//"L"
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchL___float128(void)
+{
+//+16383 in IEEE 754 2008 binary128
+//then 16383 + 1 = 16384
+ return FLT128_MAX_EXP;
+}
+
+//"O"
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchO___float128(void)
+{
+// 1.18973149535723176508575932662800702e4932Q in IEEE 754 2008 binary128.
+ return FLT128_MAX;
+}
+
+//"Z" :dummy
+//cf.http://www.netlib.org/blas/dlamch.f
+__float128 RlamchZ___float128(void)
+{
+ __float128 mtemp = 0.0;
+ return mtemp;
+}
+
+__float128 Rlamch___float128(const char *cmach)
+{
+ if (Mlsame(cmach, "E"))
+ return RlamchE___float128();
+ if (Mlsame(cmach, "S"))
+ return RlamchS___float128();
+ if (Mlsame(cmach, "B"))
+ return RlamchB___float128();
+ if (Mlsame(cmach, "P"))
+ return RlamchP___float128();
+ if (Mlsame(cmach, "N"))
+ return RlamchN___float128();
+ if (Mlsame(cmach, "R"))
+ return RlamchR___float128();
+ if (Mlsame(cmach, "M"))
+ return RlamchM___float128();
+ if (Mlsame(cmach, "U"))
+ return RlamchU___float128();
+ if (Mlsame(cmach, "L"))
+ return RlamchL___float128();
+ if (Mlsame(cmach, "O"))
+ return RlamchO___float128();
+
+ Mxerbla("Rlamch", 1);
+ return RlamchZ___float128();
+}
+#endif
+
+REAL Rlamc3(REAL a, REAL b)
+{
+ return a + b;
+}
diff --git a/mpack/Rlanst.cpp b/mpack/Rlanst.cpp
new file mode 100644
index 0000000..cf453c2
--- /dev/null
+++ b/mpack/Rlanst.cpp
@@ -0,0 +1,113 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlanst.cpp,v 1.7 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+REAL Rlanst(const char *norm, INTEGER n, REAL * d, REAL * e)
+{
+ INTEGER i;
+ REAL anorm = 0.0, scale, sum;
+ REAL Zero = 0.0, One = 1.0;
+ REAL mtemp1, mtemp2;
+
+ if (n <= 0) {
+ anorm = Zero;
+ } else if (Mlsame(norm, "M")) {
+//Find max(abs(A(i,j))).
+ anorm = abs(d[n - 1]);
+ for (i = 0; i < n - 1; i++) {
+ mtemp1 = anorm, mtemp2 = abs(d[i]);
+ anorm = max(mtemp1, mtemp2);
+ mtemp1 = anorm, mtemp2 = abs(e[i]);
+ anorm = max(mtemp1, mtemp2);
+ }
+ } else if (Mlsame(norm, "O") || Mlsame(norm, "1") || Mlsame(norm, "I")) {
+//Find norm1(A).
+ if (n == 1) {
+ anorm = abs(d[0]);
+ } else {
+ mtemp1 = abs(d[0]) + abs(e[0]), mtemp2 = abs(e[n - 2]) + abs(d[n - 1]);
+ anorm = max(mtemp1, mtemp2);
+ for (i = 1; i < n - 1; i++) {
+ mtemp1 = anorm, mtemp2 = abs(d[i]) + abs(e[i]) + abs(e[i - 1]);
+ anorm = max(mtemp1, mtemp2);
+ }
+ }
+ } else if (Mlsame(norm, "F") || Mlsame(norm, "E")) {
+//Find normF(A).
+ scale = Zero;
+ sum = One;
+ if (n > 1) {
+ Rlassq(n - 1, e, 1, &scale, &sum);
+ 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..100bd91
--- /dev/null
+++ b/mpack/Rlansy.cpp
@@ -0,0 +1,150 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlansy.cpp,v 1.6 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+REAL Rlansy(const char *norm, const char *uplo, INTEGER n, REAL * A, INTEGER lda, REAL * work)
+{
+ INTEGER i, j;
+ REAL sum, absa, scale, value = 0.0;
+ REAL Zero = 0.0, One = 1.0, Two = 2.0;
+ REAL mtemp1, mtemp2;
+
+ if (n == 0) {
+ value = Zero;
+ return value;
+ }
+ if (Mlsame(norm, "M")) {
+//Find max(abs(A(i,j))).
+ value = Zero;
+ if (Mlsame(uplo, "U")) {
+ for (j = 0; j < n; j++) {
+ for (i = 0; i <= j; i++) {
+ mtemp1 = value, mtemp2 = abs(A[i + j * lda]);
+ value = max(mtemp1, mtemp2);
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ for (i = j; i < n; i++) {
+ mtemp1 = value, mtemp2 = abs(A[i + j * lda]);
+ value = max(mtemp1, mtemp2);
+ }
+ }
+ }
+ } else if (Mlsame(norm, "I") || Mlsame(norm, "O") || Mlsame(norm, "1")) {
+//Find normI(A) ( = norm1(A), since A is symmetric).
+ value = Zero;
+ if (Mlsame(uplo, "U")) {
+ for (j = 0; j < n; j++) {
+ sum = Zero;
+ for (i = 0; i < j; i++) {
+ absa = abs(A[i + j * lda]);
+ sum = sum + absa;
+ work[i] = work[i] + absa;
+ }
+ work[j] = sum + abs(A[j + j * lda]);
+ }
+ for (i = 0; i < n; i++) {
+ mtemp1 = value, mtemp2 = work[i];
+ value = max(mtemp1, mtemp2);
+ }
+ } 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 = sum + absa;
+ work[i] = work[i] + absa;
+ }
+ mtemp1 = value, mtemp2 = sum;
+ value = max(mtemp1, mtemp2);
+ }
+ }
+ } else if (Mlsame(norm, "F") || Mlsame(norm, "E")) {
+//Find normF(A).
+ scale = Zero;
+ sum = One;
+ if (Mlsame(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 = sum * Two;
+ 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..d7eb8e1
--- /dev/null
+++ b/mpack/Rlapy2.cpp
@@ -0,0 +1,90 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlapy2.cpp,v 1.4 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+REAL Rlapy2(REAL x, REAL y)
+{
+ REAL Zero = 0.0;
+ REAL One = 1.0;
+ REAL w, z;
+
+ REAL 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..76c6ab8
--- /dev/null
+++ b/mpack/Rlarf.cpp
@@ -0,0 +1,92 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlarf.cpp,v 1.5 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rlarf(const char *side, INTEGER m, INTEGER n, REAL * v, INTEGER incv, REAL tau, REAL * C, INTEGER ldc, REAL * work)
+{
+ REAL Zero = 0.0, One = 1.0;
+ if (Mlsame(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..623d38a
--- /dev/null
+++ b/mpack/Rlarfb.cpp
@@ -0,0 +1,341 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlarfb.cpp,v 1.5 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+ * Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $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.h>
+#include <mlapack.h>
+
+void
+Rlarfb(const char *side, const char *trans, const char *direct,
+ const char *storev, INTEGER m, INTEGER n, INTEGER k, REAL * V, INTEGER ldv, REAL * T, INTEGER ldt, REAL * C, INTEGER ldc, REAL * work, INTEGER ldwork)
+{
+ INTEGER i, j;
+ REAL One = 1.0;
+ char transt;
+
+ //Quick return if possible
+ if (m <= 0 || n <= 0) {
+ return;
+ }
+ if (Mlsame(trans, "N")) {
+ transt = 'T';
+ } else {
+ transt = 'N';
+ }
+ if (Mlsame(storev, "C")) {
+ if (Mlsame(direct, "F")) {
+//Let V = (V1) (first K rows)
+// (V2)
+//where V1 is unit lower triangular.
+ if (Mlsame(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, ldv, work, 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, ldwork);
+ }
+//W: = W * T' or W * T
+ Rtrmm("Right", "Upper", &transt, "Non-unit", n, k, One, T, ldt, work, ldwork);
+//C: = C - V * W'
+ if (m > k) {
+//C2: = C2 - V2 * W'
+ Rgemm("No transpose", "Transpose", m - k, n, k, -One, &V[k], ldv, work, ldwork, One, &C[k], ldc);
+ }
+//W: = W * V1'
+ Rtrmm("Right", "Lower", "Transpose", "Unit", n, k, One, V, ldv, work, ldwork);
+//C1: = C1 - W'
+ for (j = 0; j < k; j++) {
+ for (i = 0; i < n; i++) {
+ C[j + i * ldc] = C[j + i * ldc] - work[i + j * ldwork];
+ }
+ }
+ } else if (Mlsame(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, ldv, work, 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, ldwork);
+ }
+//W: = W * T or W * T'
+ Rtrmm("Right", "Upper", trans, "Non-unit", m, k, One, T, ldt, work, ldwork);
+//C: = C - W * V'
+ if (n > k) {
+//C2: = C2 - W * V2'
+ Rgemm("No transpose", "Transpose", m, n - k, k, -One, work, ldwork, &V[k], ldv, One, &C[k * ldc], ldc);
+ }
+//W: = W * V1'
+ Rtrmm("Right", "Lower", "Transpose", "Unit", m, k, One, V, ldv, work, ldwork);
+//C1: = C1 - W
+ for (j = 0; j < k; j++) {
+ for (i = 0; i < m; i++) {
+ C[i + j * ldc] = C[i + j * ldc] - work[i + j * ldwork];
+ }
+ }
+ }
+ } else {
+//Let V = (V1)
+// (V2) (last K rows)
+//where V2 is unit upper triangular.
+ if (Mlsame(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, ldwork);
+ if (m > k) {
+//W: = W + C1'*V1
+ Rgemm("Transpose", "No transpose", n, k, m - k, One, C, ldc, V, ldv, One, work, ldwork);
+ }
+//W: = W * T' or W * T
+ Rtrmm("Right", "Lower", &transt, "Non-unit", n, k, One, T, ldt, work, ldwork);
+//C: = C - V * W'
+ if (m > k) {
+//C1:= C1 - V1 * W'
+ Rgemm("No transpose", "Transpose", m - k, n, k, -One, V, ldv, work, ldwork, One, C, ldc);
+ }
+//W: = W * V2'
+ Rtrmm("Right", "Upper", "Transpose", "Unit", n, k, One, &V[m - k], ldv, work, ldwork);
+//C2:= C2 - W'
+ for (j = 0; j < k; j++) {
+ for (i = 0; i < n; i++) {
+ C[m - k + j + i * ldc] = C[m - k + j + i * ldc] - work[i + j * ldwork];
+ }
+ }
+ } else if (Mlsame(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, ldwork);
+ if (n > k) {
+//W:= W + C1 * V1
+ Rgemm("No transpose", "No transpose", m, k, n - k, One, C, ldc, V, ldv, One, work, ldwork);
+ }
+//W:= W * T or W * T
+ Rtrmm("Right", "Lower", trans, "Non-unit", m, k, One, T, ldt, work, ldwork);
+//C:= C - W * V'
+ if (n > k) {
+//C1:= C1 - W * V1'
+ Rgemm("No transpose", "Transpose", m, n - k, k, -One, work, ldwork, V, ldv, One, C, ldc);
+ }
+//W: = W * V2'
+ Rtrmm("Right", "Upper", "Transpose", "Unit", m, k, One, &V[n - k], ldv, work, ldwork);
+//C2:= C2 - W
+ for (j = 0; j < k; j++) {
+ for (i = 0; i < m; i++) {
+ C[i + (n - k + j) * ldc] = C[i + (n - k + j) * ldc] - work[i + j * ldwork];
+ }
+ }
+ }
+ }
+ } else if (Mlsame(storev, "R")) {
+ if (Mlsame(direct, "F")) {
+//Let V = (V1 V2) (V1:first K columns)
+//where V1 is unit upper triangular.
+
+ if (Mlsame(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, ldv, work, 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, ldwork);
+ }
+//W:= W * T' or W * T
+ Rtrmm("Right", "Upper", &transt, "Non-unit", n, k, One, T, ldt, work, ldwork);
+//C:= C - V' * W'
+ if (m > k) {
+//C2:= C2 - V2' * W'
+ Rgemm("Transpose", "Transpose", m - k, n, k, -One, &V[k * ldv], ldv, work, ldwork, One, &C[k], ldc);
+ }
+//W:= W * V1
+ Rtrmm("Right", "Upper", "No transpose", "Unit", n, k, One, V, ldv, work, ldwork);
+//C1:= C1 - W'
+ for (j = 0; j < k; j++) {
+ for (i = 0; i < n; i++) {
+ C[j + i * ldc] = C[j + i * ldc] - work[i + j * ldwork];
+ }
+ }
+ } else if (Mlsame(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, ldv, work, 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, ldwork);
+ }
+//W:= W * T or W * T'
+ Rtrmm("Right", "Upper", trans, "Non-unit", m, k, One, T, ldt, work, ldwork);
+//C:= C - W * V
+ if (n > k) {
+//C2:= C2 - W * V2
+ Rgemm("No transpose", "No transpose", m, n - k, k, -One, work, ldwork, &V[k * ldv], ldv, One, &C[k * ldc], ldc);
+ }
+//W:= W * V1
+ Rtrmm("Right", "Upper", "No transpose", "Unit", m, k, One, V, ldv, work, ldwork);
+//C1:= C1 - W
+ for (j = 0; j < k; j++) {
+ for (i = 0; i < m; i++) {
+ C[i + j * ldc] = 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(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, ldwork);
+ if (m > k) {
+//W:= W + C1'*V1'
+ Rgemm("Transpose", "Transpose", n, k, m - k, One, C, ldc, V, ldv, One, work, ldwork);
+ }
+//W:= W * T' or W * T
+ Rtrmm("Right", "Lower", &transt, "Non-unit", n, k, One, T, ldt, work, ldwork);
+//C:= C - V' * W'
+ if (m > k) {
+//C1:= C1 - V1' * W'
+ Rgemm("Transpose", "Transpose", m - k, n, k, -One, V, ldv, work, ldwork, One, C, ldc);
+ }
+//W:= W * V2
+ Rtrmm("Right", "Lower", "No transpose", "Unit", n, k, One, &V[(m - k) * ldv], ldv, work, ldwork);
+//C2:= C2 - W'
+ for (j = 0; j < k; j++) {
+ for (i = 0; i < n; i++) {
+ C[m - k + j + i * ldc] = C[m - k + j + i * ldc] - work[i + j * ldwork];
+ }
+ }
+ } else if (Mlsame(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, ldwork);
+ if (n > k) {
+//W:= W + C1 * V1'
+ Rgemm("No transpose", "Transpose", m, k, n - k, One, C, ldc, V, ldv, One, work, ldwork);
+ }
+//W:= W * T or W * T'
+ Rtrmm("Right", "Lower", trans, "Non-unit", m, k, One, T, ldt, work, ldwork);
+//C:= C - W * V
+ if (n > k) {
+//C1:= C1 - W * V1
+ Rgemm("No transpose", "No transpose", m, n - k, k, -One, work, ldwork, V, ldv, One, C, ldc);
+ }
+//W:=W * V2
+ Rtrmm("Right", "Lower", "No transpose", "Unit", m, k, One, &V[(n - k) * ldv], ldv, work, ldwork);
+//C1: = C1 - W
+ for (j = 0; j < k; j++) {
+ for (i = 0; i < m; i++) {
+ C[i + (n - k + j) * ldc] = 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..01205e1
--- /dev/null
+++ b/mpack/Rlarfg.cpp
@@ -0,0 +1,121 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlarfg.cpp,v 1.7 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+#include <stdio.h> //for debugging
+void Rlarfg(INTEGER N, REAL * alpha, REAL * x, INTEGER incx, REAL * tau)
+{
+ REAL xnorm;
+ REAL One = 1.0;
+ REAL beta;
+ REAL safmin;
+ REAL rsafmn;
+ INTEGER 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("S") / Rlamch("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 (INTEGER 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..a946b28
--- /dev/null
+++ b/mpack/Rlarft.cpp
@@ -0,0 +1,136 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlarft.cpp,v 1.5 2010/08/07 04:48:32 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rlarft(const char *direct, const char *storev, INTEGER n, INTEGER k, REAL * v, INTEGER ldv, REAL * tau, REAL * t, INTEGER ldt)
+{
+ INTEGER i, j;
+ REAL vii;
+ REAL Zero = 0.0, One = 1.0;
+
+ //Quick return if possible
+ if (n == 0) {
+ return;
+ }
+ if (Mlsame(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(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(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..f8a7cab
--- /dev/null
+++ b/mpack/Rlartg.cpp
@@ -0,0 +1,148 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlartg.cpp,v 1.8 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+#include <stdio.h> //for printf
+
+void Rlartg(REAL f, REAL g, REAL * cs, REAL * sn, REAL * r)
+{
+ REAL f1, g1;
+ INTEGER i, count;
+ REAL safmin;
+ REAL safmn2;
+ REAL safmx2, eps, scale;
+ REAL Zero = 0.0, One = 1.0;
+
+ safmin = Rlamch("S");
+ eps = Rlamch("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..dc5d966
--- /dev/null
+++ b/mpack/Rlascl.cpp
@@ -0,0 +1,212 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlascl.cpp,v 1.10 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+#define MTRUE 1
+#define MFALSE 0
+
+void Rlascl(const char *type, INTEGER kl, INTEGER ku, REAL cfrom, REAL cto, INTEGER m, INTEGER n, REAL * A, INTEGER lda, INTEGER * info)
+{
+ INTEGER i, j, k1, k2, k3, k4;
+ INTEGER itype;
+ REAL bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum;
+ REAL Zero = 0.0, One = 1.0;
+ INTEGER done = MFALSE;
+
+ *info = 0;
+ if (Mlsame(type, "G")) {
+ itype = 0;
+ } else if (Mlsame(type, "L")) {
+ itype = 1;
+ } else if (Mlsame(type, "U")) {
+ itype = 2;
+ } else if (Mlsame(type, "H")) {
+ itype = 3;
+ } else if (Mlsame(type, "B")) {
+ itype = 4;
+ } else if (Mlsame(type, "Q")) {
+ itype = 5;
+ } else if (Mlsame(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((INTEGER) 1, m)) {
+ *info = -9;
+ } else if (itype >= 4) {
+ if (kl < 0 || kl > max(m - 1, (INTEGER) 0)) {
+ *info = -2;
+ } else {
+ if (ku < 0 || ku > max(n - 1, (INTEGER) 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("Rlascl", -(*info));
+ return;
+ }
+//Quick return if possible
+ if (n == 0 || m == 0) {
+ return;
+ }
+//Get machine parameters
+ smlnum = Rlamch("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] = 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, (INTEGER) 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 * 2 + 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..212cf6f
--- /dev/null
+++ b/mpack/Rlaset.cpp
@@ -0,0 +1,104 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlaset.cpp,v 1.4 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rlaset(const char *uplo, INTEGER m, INTEGER n, REAL alpha, REAL beta, REAL * A, INTEGER lda)
+{
+ INTEGER i, j;
+
+ if (Mlsame(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(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..aa6171d
--- /dev/null
+++ b/mpack/Rlasr.cpp
@@ -0,0 +1,269 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlasr.cpp,v 1.8 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rlasr(const char *side, const char *pivot, const char *direct, INTEGER m, INTEGER n, REAL * c, REAL * s, REAL * A, INTEGER lda)
+{
+ INTEGER i, j, info;
+ REAL ctemp, stemp, temp;
+ REAL Zero = 0.0, One = 1.0;
+
+//Test the input parameters
+ info = 0;
+ if (!(Mlsame(side, "L") || Mlsame(side, "R"))) {
+ info = 1;
+ } else if (!(Mlsame(pivot, "V") || Mlsame(pivot, "T")
+ || Mlsame(pivot, "B"))) {
+ info = 2;
+ } else if (!(Mlsame(direct, "F") || Mlsame(direct, "B"))) {
+ info = 3;
+ } else if (m < 0) {
+ info = 4;
+ } else if (n < 0) {
+ info = 5;
+ } else if (lda < max((INTEGER) 1, m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ Mxerbla("Rlasr ", info);
+ return;
+ }
+//Quick return if possible
+ if (m == 0 || n == 0) {
+ return;
+ }
+ if (Mlsame(side, "L")) {
+//Form P * A
+ if (Mlsame(pivot, "V")) {
+ if (Mlsame(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(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(pivot, "T")) {
+ if (Mlsame(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(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(pivot, "B")) {
+ if (Mlsame(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(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(side, "R")) {
+//Form A * P'
+ if (Mlsame(pivot, "V")) {
+ if (Mlsame(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(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(pivot, "T")) {
+ if (Mlsame(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(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(pivot, "B")) {
+ if (Mlsame(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(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..af96b28
--- /dev/null
+++ b/mpack/Rlasrt.cpp
@@ -0,0 +1,77 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlasrt.cpp,v 1.9 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+
+#include <mblas.h>
+#include <mlapack.h>
+#include <stdlib.h>
+
+int compare_mpf_gt(const REAL * a, const REAL * 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 REAL * a, const REAL * 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, INTEGER n, REAL * d, INTEGER * info)
+{
+ //Error check
+ if (!Mlsame(id, "I") && !Mlsame(id, "D")) {
+ *info = -1;
+ Mxerbla("Rlasrt", -(*info));
+ return;
+ }
+ if (n < 0) {
+ *info = -2;
+ Mxerbla("Rlasrt", -(*info));
+ return;
+ }
+ if (Mlsame(id, "I")) {
+ qsort(d, n, sizeof(REAL), (int (*)(const void *, const void *)) compare_mpf_gt);
+ }
+ if (Mlsame(id, "d")) {
+ qsort(d, n, sizeof(REAL), (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..f61e374
--- /dev/null
+++ b/mpack/Rlassq.cpp
@@ -0,0 +1,92 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlassq.cpp,v 1.4 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+//http://www.netlib.org/lapack/double/dlassq.f
+void Rlassq(INTEGER n, REAL * x, INTEGER incx, REAL * scale, REAL * sumsq)
+{
+ INTEGER ix;
+ REAL Zero = 0.0, One = 1.0;
+ REAL 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/Rlaswp.cpp b/mpack/Rlaswp.cpp
new file mode 100644
index 0000000..7c7aa6b
--- /dev/null
+++ b/mpack/Rlaswp.cpp
@@ -0,0 +1,103 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlaswp.cpp,v 1.7 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rlaswp(INTEGER n, REAL * A, INTEGER lda, INTEGER k1, INTEGER k2, INTEGER * ipiv, INTEGER incx)
+{
+ INTEGER i, k, i1, i2, ip, ix, ix0, inc;
+ REAL temp;
+
+ if (incx > 0) {
+ ix0 = k1;
+ i1 = k1;
+ i2 = k2;
+ inc = 1;
+ } else if (incx < 0) {
+ ix0 = 1 + (1 - k2) * incx;
+ i1 = k2;
+ i2 = k1;
+ inc = -1;
+ } else {
+ return;
+ }
+
+ ix = ix0;
+ for (i = i1; inc > 0 ? i <= i2 : i >= i2; i = i + inc) {
+ ip = ipiv[ix - 1];
+ if (ip != i) {
+ for (k = 1; k <= n; k++) {
+ temp = A[(i - 1) + (k - 1) * lda];
+ A[(i - 1) + (k - 1) * lda] = A[(ip - 1) + (k - 1) * lda];
+ A[(ip - 1) + (k - 1) * lda] = temp;
+ }
+ }
+ ix = ix + incx;
+ }
+ return;
+}
diff --git a/mpack/Rlatrd.cpp b/mpack/Rlatrd.cpp
new file mode 100644
index 0000000..1c283c5
--- /dev/null
+++ b/mpack/Rlatrd.cpp
@@ -0,0 +1,136 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rlatrd.cpp,v 1.6 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rlatrd(const char *uplo, INTEGER n, INTEGER nb, REAL * A, INTEGER lda, REAL * e, REAL * tau, REAL * w, INTEGER ldw)
+{
+ INTEGER i, iw;
+ REAL alpha;
+ REAL Zero = 0.0, Half = 0.5, One = 1.0;
+
+//Quick return if possible
+ if (n <= 0) {
+ return;
+ }
+ if (Mlsame(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..f9a4c2a
--- /dev/null
+++ b/mpack/Rnrm2.cpp
@@ -0,0 +1,104 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rnrm2.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rnrm2.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/dnrm2.f
+Rnrm2 returns the euclidean norm of a vector, sqrt( x'*x ).
+*/
+
+#include <mblas.h>
+
+REAL Rnrm2(INTEGER n, REAL * x, INTEGER incx)
+{
+ INTEGER ix;
+ REAL Zero = 0.0, One = 1.0;
+ REAL 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 (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..f276f36
--- /dev/null
+++ b/mpack/Rorg2l.cpp
@@ -0,0 +1,114 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rorg2l.cpp,v 1.9 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rorg2l(INTEGER m, INTEGER n, INTEGER k, REAL * A, INTEGER lda, REAL * tau, REAL * work, INTEGER * info)
+{
+ INTEGER i, ii, j, l;
+ REAL 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((INTEGER) 1, m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ Mxerbla("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..89048a1
--- /dev/null
+++ b/mpack/Rorg2r.cpp
@@ -0,0 +1,117 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rorg2r.cpp,v 1.9 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rorg2r(INTEGER m, INTEGER n, INTEGER k, REAL * A, INTEGER lda, REAL * tau, REAL * work, INTEGER * info)
+{
+ INTEGER i, j, l;
+ REAL 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((INTEGER) 1, m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ Mxerbla("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..85d2fb0
--- /dev/null
+++ b/mpack/Rorgql.cpp
@@ -0,0 +1,168 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rorgql.cpp,v 1.12 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rorgql(INTEGER m, INTEGER n, INTEGER k, REAL * A, INTEGER lda, REAL * tau, REAL * work, INTEGER lwork, INTEGER * info)
+{
+ INTEGER nbmin, nx, iws, nb = 0, lwkopt, lquery, kk;
+ INTEGER i, j, l, iinfo, ldwork = 0, ib;
+ REAL Zero = 0.0;
+
+//Test the input arguments
+ *info = 0;
+ lquery = lwork == -1;
+ 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((INTEGER) 1, m)) {
+ *info = -5;
+ }
+ if (*info == 0) {
+ if (n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = iMlaenv(1, "Rorgql", " ", m, n, k, -1);
+ lwkopt = n * nb;
+ }
+ work[0] = lwkopt;
+ if (lwork < max((INTEGER) 1, n) && !lquery) {
+ *info = -8;
+ }
+ }
+ if (*info != 0) {
+ Mxerbla("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((INTEGER) 0, iMlaenv(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((INTEGER) 2, iMlaenv(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) {
+//Use blocked code
+ 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] = iws;
+ return;
+}
diff --git a/mpack/Rorgqr.cpp b/mpack/Rorgqr.cpp
new file mode 100644
index 0000000..926497b
--- /dev/null
+++ b/mpack/Rorgqr.cpp
@@ -0,0 +1,165 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rorgqr.cpp,v 1.11 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rorgqr(INTEGER m, INTEGER n, INTEGER k, REAL * A, INTEGER lda, REAL * tau, REAL * work, INTEGER lwork, INTEGER * info)
+{
+ INTEGER nbmin, nx, iws, nb, lwkopt, lquery, ki = 0, kk;
+ INTEGER i, j, l, iinfo, ldwork = 0, ib;
+ REAL Zero = 0.0, One = 1.0;
+
+//Test the input arguments
+ *info = 0;
+ nb = iMlaenv(1, "Rorgqr", " ", m, n, k, -1);
+ lwkopt = max((INTEGER) 1, n) * nb;
+ work[0] = lwkopt;
+ lquery = lwork == -1;
+ 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((INTEGER) 1, m)) {
+ *info = -5;
+ } else if (lwork < max((INTEGER) 1, n) && !lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ Mxerbla("Rorgqr", -(*info));
+ return;
+ } else if (lquery) {
+ return;
+ }
+//Quick return if possible
+ 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((INTEGER) 0, iMlaenv(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((INTEGER) 2, iMlaenv(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] = iws;
+ return;
+}
diff --git a/mpack/Rorgtr.cpp b/mpack/Rorgtr.cpp
new file mode 100644
index 0000000..83cd099
--- /dev/null
+++ b/mpack/Rorgtr.cpp
@@ -0,0 +1,151 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rorgtr.cpp,v 1.9 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rorgtr(const char *uplo, INTEGER n, REAL * A, INTEGER lda, REAL * tau, REAL * work, INTEGER lwork, INTEGER * info)
+{
+ INTEGER lquery, lwkopt, iinfo, upper, nb;
+ INTEGER i, j;
+ REAL Zero = 0.0, One = 1.0;
+
+//Test the input arguments
+ *info = 0;
+ lquery = lwork == -1;
+ upper = Mlsame(uplo, "U");
+ if (!upper && !Mlsame(uplo, "L")) {
+ *info = -1;
+ } else if (n < 0) {
+ *info = -2;
+ } else if (lda < max((INTEGER) 1, n)) {
+ *info = -4;
+ } else {
+ if (lwork < max((INTEGER) 1, n - 1) && !lquery) {
+ *info = -7;
+ }
+ }
+ if (*info == 0) {
+ if (upper) {
+ nb = iMlaenv(1, "Rorgql", " ", n - 1, n - 1, n - 1, -1);
+ } else {
+ nb = iMlaenv(1, "Rorgqr", " ", n - 1, n - 1, n - 1, -1);
+ }
+ lwkopt = max((INTEGER) 1, n - 1) * nb;
+ work[0] = lwkopt;
+ }
+ if (*info != 0) {
+ Mxerbla("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 Rsytrd 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] = lwkopt;
+ return;
+}
diff --git a/mpack/Rpotf2.cpp b/mpack/Rpotf2.cpp
new file mode 100644
index 0000000..be88b4a
--- /dev/null
+++ b/mpack/Rpotf2.cpp
@@ -0,0 +1,134 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rpotf2.cpp,v 1.10 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rpotf2(const char *uplo, INTEGER n, REAL * A, INTEGER lda, INTEGER * info)
+{
+ INTEGER j, upper, success = 1;
+ REAL ajj;
+ REAL Zero = 0.0, One = 1.0;
+
+ *info = 0;
+ upper = Mlsame(uplo, "U");
+ if (!upper && !Mlsame(uplo, "L")) {
+ *info = -1;
+ } else if (n < 0) {
+ *info = -2;
+ } else if (lda < max((INTEGER) 1, n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ Mxerbla("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..d16100e
--- /dev/null
+++ b/mpack/Rpotrf.cpp
@@ -0,0 +1,144 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rpotrf.cpp,v 1.9 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rpotrf(const char *uplo, INTEGER n, REAL * A, INTEGER lda, INTEGER * info)
+{
+ INTEGER upper;
+ INTEGER j, jb, nb;
+ REAL One = 1.0;
+
+//Test the input parameters.
+ *info = 0;
+ upper = Mlsame(uplo, "U");
+ if (!upper && !Mlsame(uplo, "L")) {
+ *info = -1;
+ } else if (n < 0) {
+ *info = -2;
+ } else if (lda < max((INTEGER) 1, n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ Mxerbla("Rpotrf", -(*info));
+ return;
+ }
+//Quick return if possible
+ if (n == 0) {
+ return;
+ }
+//Determine the block size for this environment.
+ nb = iMlaenv(1, "Rpotrf", uplo, n, -1, -1, -1);
+ if (nb <= 1 || nb >= n) {
+//Use unblocked code.
+ Rpotf2(uplo, n, A, lda, info);
+ } else {
+//Use blocked code.
+ if (upper) {
+//Compute the Cholesky factorization A = U'*U.
+ for (j = 1; j <= n; j = j + nb) {
+//Update and factorize the current diagonal block and test
+//for non-positive-definiteness.
+ jb = min(nb, n - j + 1);
+ Rsyrk("Upper", "Transpose", jb, j - 1, -One, &A[0 + (j - 1) * lda], lda, One, &A[(j - 1) + (j - 1) * lda], lda);
+ Rpotf2("Upper", jb, &A[(j - 1) + (j - 1) * lda], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= n) {
+//Compute the current block row.
+ Rgemm("Transpose", "No transpose", jb, n - j - jb + 1,
+ j - 1, -One, &A[0 + (j - 1) * lda], lda, &A[0 + (j + jb - 1) * lda], lda, One, &A[(j - 1) + (j + jb - 1) * lda], lda);
+ Rtrsm("Left", "Upper", "Transpose", "Non-unit", jb, n - j - jb + 1, One, &A[(j - 1) + (j - 1) * lda], lda, &A[(j - 1) + (j + jb - 1) * lda], lda);
+ }
+ }
+ } else {
+//Compute the Cholesky factorization A = L*L'.
+ for (j = 1; j <= n; j = j + nb) {
+//Update and factorize the current diagonal block and test
+//for non-positive-definiteness.
+ jb = min(nb, n - j + 1);
+ Rsyrk("Lower", "No transpose", jb, j - 1, -One, &A[(j - 1) + 0 * lda], lda, One, &A[(j - 1) + (j - 1) * lda], lda);
+ Rpotf2("Lower", jb, &A[(j - 1) + (j - 1) * lda], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= n) {
+//Compute the current block column.
+ Rgemm("No transpose", "Transpose", n - j - jb + 1, jb,
+ j - 1, -One, &A[(j + jb - 1) + 0 * lda], lda, &A[(j - 1) + 0 * lda], lda, One, &A[(j + jb - 1) + (j - 1) * lda], lda);
+ Rtrsm("Right", "Lower", "Transpose", "Non-unit", n - j - jb + 1, jb, One, &A[(j - 1) + (j - 1) * lda], lda, &A[(j + jb - 1) + (j - 1) * lda], lda);
+ }
+ }
+ }
+ }
+ return;
+ L30:
+ *info = *info + j - 1;
+ return;
+}
diff --git a/mpack/Rrot.cpp b/mpack/Rrot.cpp
new file mode 100644
index 0000000..217cc36
--- /dev/null
+++ b/mpack/Rrot.cpp
@@ -0,0 +1,99 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rrot.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rrot.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/drot.f
+applies a plane rotation.
+*/
+
+#include <mblas.h>
+
+void Rrot(INTEGER n, REAL * dx, INTEGER incx, REAL * dy, INTEGER incy, REAL c, REAL s)
+{
+ INTEGER i, ix, iy;
+ REAL temp;
+
+ if (n <= 0)
+ return;
+ ix = 0;
+ iy = 0;
+
+ if (incx < 0)
+ ix = (-n + 1) * incx;
+ if (incy < 0)
+ iy = (-n + 1) * incy;
+ for (i = 0; i < n; i++) {
+ temp = c * dx[ix] + s * dy[iy];
+ dy[iy] = c * dy[iy] - s * dx[ix];
+ dx[ix] = temp;
+ ix = ix + incx;
+ iy = iy + incy;
+ }
+ return;
+}
diff --git a/mpack/Rrotg.cpp b/mpack/Rrotg.cpp
new file mode 100644
index 0000000..595b455
--- /dev/null
+++ b/mpack/Rrotg.cpp
@@ -0,0 +1,103 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rrotg.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rrotg.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/drotg.f
+*/
+
+#include <mblas.h>
+
+void Rrotg(REAL * da, REAL * db, REAL * c, REAL * s)
+{
+ REAL roe, scale;
+ REAL r, z;
+
+ roe = *db;
+ if (abs(*da) > abs(*db))
+ roe = *da;
+ scale = abs(*da) + abs(*db);
+ if (scale == 0.0) {
+ (*c) = 1.0;
+ (*s) = 0.0;
+ r = 0.0;
+ z = 0.0;
+ } else {
+ r = scale * sqrt(((*da) / scale) * ((*da) / scale) + ((*db) / scale) * ((*db) / scale));
+ r = Msign(1.0, roe) * r;
+ (*c) = (*da) / r;
+ (*s) = (*db) / r;
+ z = 1.0;
+ if (abs(*da) > abs(*db))
+ z = *s;
+ if (abs(*db) >= abs(*da) && *c != 0.0)
+ z = 1.0 / (*c);
+ }
+ *da = r;
+ *db = z;
+}
diff --git a/mpack/Rscal.cpp b/mpack/Rscal.cpp
new file mode 100644
index 0000000..52faa60
--- /dev/null
+++ b/mpack/Rscal.cpp
@@ -0,0 +1,88 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rscal.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rscal.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+/*
+Based on http://www.netlib.org/blas/dscal.f
+scales a vector by a constant.
+*/
+
+#include <mblas.h>
+
+void Rscal(INTEGER n, REAL da, REAL * dx, INTEGER incx)
+{
+ INTEGER i, nincx;
+
+ if (n <= 0 || incx <= 0)
+ return;
+
+ nincx = n * incx;
+ for (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..4a32d28
--- /dev/null
+++ b/mpack/Rsteqr.cpp
@@ -0,0 +1,413 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsteqr.cpp,v 1.13 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+#include <iostream>
+
+void Rsteqr(const char *compz, INTEGER n, REAL * d, REAL * e, REAL * z, INTEGER ldz, REAL * work, INTEGER * info)
+{
+ INTEGER nmaxit, maxit, jtot, l1, nm1;
+ INTEGER i, m, mm, mm1, l, lm1, lend, lsv, lendsv, lendm1, iscale, icompz;
+ INTEGER lendp1, ii, k, j;
+ REAL eps, eps2, safmin, safmax, ssfmax, ssfmin;
+ REAL c, s, rt1, rt2;
+ REAL tst, anorm;
+ REAL f, b, p, g, r;
+ REAL Zero = 0.0, One = 1.0, Two = 2.0, Three = 3.0;
+
+ maxit = 30;
+//Test the input parameters.
+ *info = 0;
+ if (Mlsame(compz, "N")) {
+ icompz = 0;
+ } else if (Mlsame(compz, "V")) {
+ icompz = 1;
+ } else if (Mlsame(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((INTEGER) 1, n))) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ Mxerbla("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("E");
+ eps2 = eps * eps;
+ safmin = Rlamch("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 * maxit;
+ 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] = 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;
+ std::cout << "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;
+ std::cout << "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..a921ab2
--- /dev/null
+++ b/mpack/Rsterf.cpp
@@ -0,0 +1,338 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsterf.cpp,v 1.14 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+#include <iostream>
+
+void Rsterf(INTEGER n, REAL * d, REAL * e, INTEGER * info)
+{
+ INTEGER nmaxit, maxit;
+ INTEGER iscale;
+ INTEGER l1, jtot;
+ INTEGER i, l, m;
+ INTEGER lsv, lend, lendsv;
+ REAL sigma;
+ REAL eps, eps2;
+ REAL safmin, safmax, ssfmax, ssfmin, anorm;
+ REAL rte, rt1, rt2, s, c, r, oldc, oldgam, gamma, p, bb, alpha;
+ REAL Zero = 0.0, One = 1.0, Two = 2.0, Three = 3.0;
+
+ maxit = 30;
+ *info = 0;
+//Quick return if possible
+ if (n < 0) {
+ *info = -1;
+ Mxerbla("Rsterf", -(*info));
+ return;
+ }
+ if (n <= 1)
+ return;
+//Determine the unit roundoff for this environment.
+ eps = Rlamch("E");
+ eps2 = eps * eps;
+ safmin = Rlamch("S");
+ safmax = One / safmin;
+ ssfmax = sqrt(safmax) / Three;
+ ssfmin = sqrt(safmin) / eps2;
+//Compute the eigenvalues of the tridiagonal matrix.
+ nmaxit = n * maxit;
+ 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) {
+ std::cout << "XXX Rsterf 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) {
+ std::cout << "XXX Rsterf 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..6f0c2dc
--- /dev/null
+++ b/mpack/Rswap.cpp
@@ -0,0 +1,99 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rswap.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rswap.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/dswap.f
+INTEGERerchanges two vectors.
+*/
+
+#include <mblas.h>
+
+void Rswap(INTEGER n, REAL * dx, INTEGER incx, REAL * dy, INTEGER incy)
+{
+ INTEGER i, ix, iy;
+ REAL temp;
+
+ if (n <= 0)
+ return;
+ ix = 0;
+ iy = 0;
+
+ if (incx < 0)
+ ix = (-n + 1) * incx;
+ if (incy < 0)
+ iy = (-n + 1) * incy;
+ for (i = 0; i < n; i++) {
+ temp = 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..36c71cf
--- /dev/null
+++ b/mpack/Rsyev.cpp
@@ -0,0 +1,168 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsyev.cpp,v 1.11 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rsyev(const char *jobz, const char *uplo, INTEGER n, REAL * A, INTEGER lda, REAL * w, REAL * work, INTEGER lwork, INTEGER * info)
+{
+ INTEGER wantz, lower, lquery, nb, lwkopt, iscale, imax;
+ INTEGER inde, indtau, indwrk, llwork, iinfo;
+ REAL safmin, eps, smlnum, bignum, rmin, rmax;
+ REAL sigma = 0.0, anrm;
+ REAL rtmp;
+ REAL Zero = 0.0, One = 1.0, Two = 2.0;
+
+//Test the input parameters.
+ wantz = Mlsame(jobz, "V");
+ lower = Mlsame(uplo, "L");
+ lquery = lwork == -1;
+ *info = 0;
+ if (!(wantz || Mlsame(jobz, "N"))) {
+ *info = -1;
+ } else if (!(lower || Mlsame(uplo, "U"))) {
+ *info = -2;
+ } else if (n < 0) {
+ *info = -3;
+ } else if (lda < max((INTEGER) 1, n)) {
+ *info = -5;
+ }
+ if (*info == 0) {
+ nb = iMlaenv(1, "Rsytrd", uplo, n, -1, -1, -1);
+ lwkopt = max((INTEGER) 1, (nb + 2) * n);
+ work[0] = lwkopt;
+ if (lwork < max((INTEGER) 1, 3 * n - 1) && !lquery) {
+ *info = -8;
+ }
+ }
+ if (*info != 0) {
+ Mxerbla("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("Safe minimum");
+ eps = Rlamch("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 Rsytrd to reduce symmetric matrix to tridiagonal form.
+ inde = 1;
+ indtau = inde + n;
+ indwrk = indtau + n;
+ llwork = lwork - indwrk + 1;
+ Rsytrd(uplo, n, A, lda, w, &work[inde - 1], &work[indtau - 1], &work[indwrk - 1], llwork, &iinfo);
+//For eigenvalues only, call Rsterf. For eigenvectors, first call
+//Rorgtr to generate the orthogonal matrix, then call Rsteqr.
+ if (!wantz) {
+ Rsterf(n, w, &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, 1);
+ }
+//Set WORK(0) to optimal workspace size.
+ work[0] = lwkopt;
+ return;
+}
diff --git a/mpack/Rsymv.cpp b/mpack/Rsymv.cpp
new file mode 100644
index 0000000..56c0edf
--- /dev/null
+++ b/mpack/Rsymv.cpp
@@ -0,0 +1,179 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsymv.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rsymv.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rsymv(const char *uplo, INTEGER n, REAL alpha, REAL * A, INTEGER lda, REAL * x, INTEGER incx, REAL beta, REAL * y,
+ INTEGER incy)
+{
+ INTEGER i, ix, iy, j, jx, jy, kx, ky, info = 0;
+ REAL Zero = 0.0, One = 1.0;
+ REAL temp1, temp2;
+
+//test the input parameters.
+ if (!Mlsame(uplo, "U") && !Mlsame(uplo, "L"))
+ info = 1;
+ else if (n < 0)
+ info = 2;
+ else if (lda < max((INTEGER) 1, n))
+ info = 5;
+ else if (incx == 0)
+ info = 7;
+ else if (incy == 0)
+ info = 10;
+
+ if (info != 0) {
+ Mxerbla("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 (i = 0; i < n; i++) {
+ y[iy] = Zero;
+ iy = iy + incy;
+ }
+ } else {
+ for (i = 0; i < n; i++) {
+ y[iy] = beta * y[iy];
+ iy = iy + incy;
+ }
+ }
+ }
+ if (alpha == Zero)
+ return;
+
+ if (Mlsame(uplo, "U")) {
+//form y when a is stored in upper triangle.
+ jx = kx;
+ jy = ky;
+ for (j = 0; j < n; j++) {
+ temp1 = alpha * x[jx];
+ temp2 = Zero;
+ ix = kx;
+ iy = ky;
+ for (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 (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 (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..9adef7d
--- /dev/null
+++ b/mpack/Rsyr2.cpp
@@ -0,0 +1,152 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsyr2.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rsyr2.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rsyr2(const char *uplo, INTEGER n, REAL alpha, REAL * x, INTEGER incx, REAL * y, INTEGER incy, REAL * A, INTEGER lda)
+{
+ INTEGER i, ix, iy, j, jx, jy, kx, ky, info;
+ REAL temp1, temp2;
+ REAL Zero = 0.0;
+
+//test the input parameters.
+ info = 0;
+ if (!Mlsame(uplo, "U") && !Mlsame(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((INTEGER) 1, n))
+ info = 9;
+ if (info != 0) {
+ Mxerbla("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(uplo, "U")) {
+ for (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 (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 (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 (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..5232134
--- /dev/null
+++ b/mpack/Rsyr2k.cpp
@@ -0,0 +1,236 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsyr2k.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rsyr2k.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+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.h>
+
+void Rsyr2k(const char *uplo, const char *trans, INTEGER n, INTEGER k, REAL alpha, REAL * A, INTEGER lda, REAL * B, INTEGER ldb,
+ REAL beta, REAL * C, INTEGER ldc)
+{
+ INTEGER i, j, l, nrowa, upper, info;
+ REAL Zero = 0.0, One = 1.0;
+ REAL temp1, temp2;
+
+//test the input parameters.
+ if (Mlsame(trans, "N"))
+ nrowa = n;
+ else
+ nrowa = k;
+ upper = Mlsame(uplo, "U");
+
+ info = 0;
+ if ((!upper) && (!Mlsame(uplo, "L")))
+ info = 1;
+ else if ((!Mlsame(trans, "N")) && (!Mlsame(trans, "T")) && (!Mlsame(trans, "C")))
+ info = 2;
+ else if (n < 0)
+ info = 3;
+ else if (k < 0)
+ info = 4;
+ else if (lda < max((INTEGER) 1, nrowa))
+ info = 7;
+ else if (ldb < max((INTEGER) 1, nrowa))
+ info = 9;
+ else if (ldc < max((INTEGER) 1, n))
+ info = 12;
+ if (info != 0) {
+ Mxerbla("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 (j = 0; j < n; j++) {
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ }
+ } else {
+ if (beta == Zero) {
+ for (j = 0; j < n; j++) {
+ for (i = j; i < n; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ for (i = j; i < n; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ }
+ }
+ return;
+ }
+//start the operations.
+ if (Mlsame(trans, "N")) {
+//form C:= alpha*A*B' + alpha*B*A'+C.
+ if (upper) {
+ for (j = 0; j < n; j++) {
+ if (beta == Zero) {
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ } else if (beta != One) {
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ for (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 (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 (j = 0; j < n; j++) {
+ if (beta == Zero) {
+ for (i = j; i < n; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ } else if (beta != One) {
+ for (i = j; i < n; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ for (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 (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 (j = 0; j < n; j++) {
+ for (i = 0; i <= j; i++) {
+ temp1 = Zero;
+ temp2 = Zero;
+ for (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 (j = 0; j < n; j++) {
+ for (i = j; i < n; i++) {
+ temp1 = Zero;
+ temp2 = Zero;
+ for (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..7d65ee7
--- /dev/null
+++ b/mpack/Rsyrk.cpp
@@ -0,0 +1,226 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsyrk.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rsyrk.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+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.h>
+
+void Rsyrk(const char *uplo, const char *trans, INTEGER n, INTEGER k, REAL alpha, REAL * A, INTEGER lda, REAL beta, REAL * C,
+ INTEGER ldc)
+{
+ INTEGER i, j, l, nrowa, upper, info;
+ REAL Zero = 0.0, One = 1.0;
+ REAL temp;
+
+//Test the input parameters.
+ if (Mlsame(trans, "N"))
+ nrowa = n;
+ else
+ nrowa = k;
+ upper = Mlsame(uplo, "U");
+
+ info = 0;
+ if ((!upper) && (!Mlsame(uplo, "L")))
+ info = 1;
+ else if ((!Mlsame(trans, "N")) && (!Mlsame(trans, "T")) && (!Mlsame(trans, "C")))
+ info = 2;
+ else if (n < 0)
+ info = 3;
+ else if (k < 0)
+ info = 4;
+ else if (lda < max((INTEGER) 1, nrowa))
+ info = 7;
+ else if (ldc < max((INTEGER) 1, n))
+ info = 10;
+ if (info != 0) {
+ Mxerbla("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 (j = 0; j < n; j++) {
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ }
+ } else {
+ if (beta == Zero) {
+ for (j = 0; j < n; j++) {
+ for (i = j; i < n; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ for (i = j; i < n; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ }
+ }
+ return;
+ }
+//start the operations.
+ if (Mlsame(trans, "N")) {
+//Form C := alpha*A*A' + beta*C.
+ if (upper) {
+ for (j = 0; j < n; j++) {
+ if (beta == Zero) {
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ } else if (beta != One) {
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ for (l = 0; l < k; l++) {
+ if (A[j + l * lda] != Zero) {
+ temp = alpha * A[j + l * lda];
+ for (i = 0; i <= j; i++) {
+ C[i + j * ldc] = C[i + j * ldc] + temp * A[i + l * lda];
+ }
+ }
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ if (beta == Zero) {
+ for (i = j; i < n; i++) {
+ C[i + j * ldc] = Zero;
+ }
+ } else if (beta != One) {
+ for (i = j; i < n; i++) {
+ C[i + j * ldc] = beta * C[i + j * ldc];
+ }
+ }
+ for (l = 0; l < k; l++) {
+ if (A[j + l * lda] != Zero) {
+ temp = alpha * A[j + l * lda];
+ for (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 (j = 0; j < n; j++) {
+ for (i = 0; i <= j; i++) {
+ temp = Zero;
+ for (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 (j = 0; j < n; j++) {
+ for (i = j; i < n; i++) {
+ temp = Zero;
+ for (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..863897b
--- /dev/null
+++ b/mpack/Rsytd2.cpp
@@ -0,0 +1,145 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsytd2.cpp,v 1.9 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rsytd2(const char *uplo, INTEGER n, REAL * A, INTEGER lda, REAL * d, REAL * e, REAL * tau, INTEGER * info)
+{
+ INTEGER upper;
+ INTEGER i;
+ REAL taui, alpha;
+ REAL Zero = 0.0, Half = 0.5, One = 1.0;
+
+ *info = 0;
+ upper = Mlsame(uplo, "U");
+ if (!upper && !Mlsame(uplo, "L")) {
+ *info = -1;
+ } else if (n < 0) {
+ *info = -2;
+ } else if (lda < max((INTEGER) 1, n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ Mxerbla("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..bcaa4d9
--- /dev/null
+++ b/mpack/Rsytrd.cpp
@@ -0,0 +1,178 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rsytrd.cpp,v 1.12 2010/08/07 04:48:33 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+
+void Rsytrd(const char *uplo, INTEGER n, REAL * A, INTEGER lda, REAL * d, REAL * e, REAL * tau, REAL * work, INTEGER lwork, INTEGER * info)
+{
+ INTEGER upper, lquery, nb, lwkopt, nx, iws;
+ INTEGER ldwork = 0, nbmin, kk;
+ INTEGER i, j;
+ INTEGER iinfo;
+ REAL One = 1.0;
+
+//Test the input parameters
+ *info = 0;
+ upper = Mlsame(uplo, "U");
+ lquery = lwork == -1;
+ if (!upper && !Mlsame(uplo, "L")) {
+ *info = -1;
+ } else if (n < 0) {
+ *info = -2;
+ } else if (lda < max((INTEGER) 1, n)) {
+ *info = -4;
+ } else if (lwork < 1 && !lquery) {
+ *info = -9;
+ }
+ if (*info == 0) {
+//Determine the block size.
+ nb = iMlaenv(1, "Rsytrd", uplo, n, -1, -1, -1);
+ lwkopt = n * nb;
+ work[0] = lwkopt;
+ }
+ if (*info != 0) {
+ Mxerbla("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(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, (INTEGER) 1);
+ nbmin = iMlaenv(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+nb:n,i+nb: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] = lwkopt;
+ return;
+}
diff --git a/mpack/Rtrmm.cpp b/mpack/Rtrmm.cpp
new file mode 100644
index 0000000..6b2b979
--- /dev/null
+++ b/mpack/Rtrmm.cpp
@@ -0,0 +1,273 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rtrmm.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rtrmm.cpp,v 1.6 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rtrmm(const char *side, const char *uplo, const char *transa, const char *diag, INTEGER m, INTEGER n, REAL alpha, REAL * A,
+ INTEGER lda, REAL * B, INTEGER ldb)
+{
+ INTEGER i, j, k, info, lside, nrowa, nounit, upper;
+ REAL temp;
+ REAL Zero = 0.0, One = 1.0;
+
+//test the input parameters.
+ lside = Mlsame(side, "L");
+ if (lside)
+ nrowa = m;
+ else
+ nrowa = n;
+
+ nounit = Mlsame(diag, "N");
+ upper = Mlsame(uplo, "U");
+ info = 0;
+ if ((!lside) && (!Mlsame(side, "R")))
+ info = 1;
+ else if ((!upper) && (!Mlsame(uplo, "L")))
+ info = 2;
+ else if ((!Mlsame(transa, "N")) && (!Mlsame(transa, "T")) && (!Mlsame(transa, "C")))
+ info = 3;
+ else if ((!Mlsame(diag, "U")) && (!Mlsame(diag, "N")))
+ info = 4;
+ else if (m < 0)
+ info = 5;
+ else if (n < 0)
+ info = 6;
+ else if (lda < max((INTEGER) 1, nrowa))
+ info = 9;
+ else if (ldb < max((INTEGER) 1, m))
+ info = 11;
+ if (info != 0) {
+ Mxerbla("Rtrmm ", info);
+ return;
+ }
+//quick return if possible.
+ if (m == 0 || n == 0)
+ return;
+
+//and when alpha==Zero.
+ if (alpha == Zero) {
+ for (j = 0; j < n; j++) {
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = Zero;
+ }
+ }
+ return;
+ }
+//start the operations.
+ if (lside) {
+ if (Mlsame(transa, "N")) {
+//Form B := alpha*A*B.
+ if (upper) {
+ for (j = 0; j < n; j++) {
+ for (k = 0; k < m; k++) {
+ if (B[k + j * ldb] != Zero) {
+ temp = alpha * B[k + j * ldb];
+ for (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 (j = 0; j < n; j++) {
+ for (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 (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 (j = 0; j < n; j++) {
+ for (i = m - 1; i >= 0; i--) {
+ temp = B[i + j * ldb];
+ if (nounit)
+ temp = temp * A[i + i * lda];
+ for (k = 0; k < i; k++) {
+ temp = temp + A[k + i * lda] * B[k + j * ldb];
+ }
+ B[i + j * ldb] = alpha * temp;
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ for (i = 0; i < m; i++) {
+ temp = B[i + j * ldb];
+ if (nounit)
+ temp = temp * A[i + i * lda];
+ for (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(transa, "N")) {
+//Form B := alpha*B*A.
+ if (upper) {
+ for (j = n - 1; j >= 0; j--) {
+ temp = alpha;
+ if (nounit)
+ temp = temp * A[j + j * lda];
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = temp * B[i + j * ldb];
+ }
+ for (k = 0; k < j; k++) {
+ if (A[k + j * lda] != Zero) {
+ temp = alpha * A[k + j * lda];
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = B[i + j * ldb] + temp * B[i + k * ldb];
+ }
+ }
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ temp = alpha;
+ if (nounit)
+ temp = temp * A[j + j * lda];
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = temp * B[i + j * ldb];
+ }
+ for (k = j + 1; k < n; k++) {
+ if (A[k + j * lda] != Zero) {
+ temp = alpha * A[k + j * lda];
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = B[i + j * ldb] + temp * B[i + k * ldb];
+ }
+ }
+ }
+ }
+ }
+ } else {
+ if (upper) {
+ for (k = 0; k < n; k++) {
+ for (j = 0; j < k; j++) {
+ if (A[j + k * lda] != Zero) {
+ temp = alpha * A[j + k * lda];
+ for (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 (i = 0; i < m; i++) {
+ B[i + k * ldb] = temp * B[i + k * ldb];
+ }
+ }
+ }
+ } else {
+ for (k = n - 1; k >= 0; k--) {
+ for (j = k + 1; j < n; j++) {
+ if (A[j + k * lda] != Zero) {
+ temp = alpha * A[j + k * lda];
+ for (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 (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..d14a9d5
--- /dev/null
+++ b/mpack/Rtrmv.cpp
@@ -0,0 +1,186 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rtrmv.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rtrmv.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rtrmv(const char *uplo, const char *trans, const char *diag, INTEGER n, REAL * A, INTEGER lda, REAL * x, INTEGER incx)
+{
+ INTEGER i, j, ix, jx, kx, info, nounit;
+ REAL temp;
+ REAL Zero = 0.0;
+
+//Test the input parameters.
+ info = 0;
+ if (!Mlsame(uplo, "U") && !Mlsame(uplo, "L"))
+ info = 1;
+ else if (!Mlsame(trans, "N") && !Mlsame(trans, "T") && !Mlsame(trans, "C"))
+ info = 2;
+ else if (!Mlsame(diag, "U") && !Mlsame(diag, "N"))
+ info = 3;
+ else if (n < 0)
+ info = 4;
+ else if (lda < max((INTEGER) 1, n))
+ info = 6;
+ else if (incx == 0)
+ info = 8;
+
+ if (info != 0) {
+ Mxerbla("Rtrmv ", info);
+ return;
+ }
+//quick return if possible.
+ if (n == 0)
+ return;
+
+ nounit = Mlsame(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(trans, "N")) {
+//form x := A*x.
+ if (Mlsame(uplo, "U")) {
+ jx = kx;
+ for (j = 0; j < n; j++) {
+ if (x[jx] != Zero) {
+ temp = x[jx];
+ ix = kx;
+ for (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 (j = n - 1; j >= 0; j--) {
+ if (x[jx] != Zero) {
+ temp = x[jx];
+ ix = kx;
+ for (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(uplo, "U")) {
+ jx = kx + (n - 1) * incx;
+ for (j = n - 1; j >= 0; j--) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit)
+ temp = temp * A[j + j * lda];
+ for (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 (j = 0; j < n; j++) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit)
+ temp = temp * A[j + j * lda];
+ for (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..6bb2621
--- /dev/null
+++ b/mpack/Rtrsm.cpp
@@ -0,0 +1,296 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rtrsm.cpp,v 1.7 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rtrsm.cpp,v 1.7 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rtrsm(const char *side, const char *uplo, const char *transa, const char *diag, INTEGER m, INTEGER n, REAL alpha, REAL * A,
+ INTEGER lda, REAL * B, INTEGER ldb)
+{
+ INTEGER i, info, j, k, lside, nrowa, nounit, upper;
+ REAL Zero = 0.0, One = 1.0;
+ REAL temp;
+
+//test the input parameters.
+ lside = Mlsame(side, "L");
+ if (lside)
+ nrowa = m;
+ else
+ nrowa = n;
+
+ nounit = Mlsame(diag, "N");
+ upper = Mlsame(uplo, "U");
+
+ info = 0;
+ if ((!lside) && (!Mlsame(side, "R")))
+ info = 1;
+ else if ((!upper) && (!Mlsame(uplo, "L")))
+ info = 2;
+ else if ((!Mlsame(transa, "N")) && (!Mlsame(transa, "T")) && (!Mlsame(transa, "C")))
+ info = 3;
+ else if ((!Mlsame(diag, "U")) && (!Mlsame(diag, "N")))
+ info = 4;
+ else if (m < 0)
+ info = 5;
+ else if (n < 0)
+ info = 6;
+ else if (lda < max((INTEGER) 1, nrowa))
+ info = 9;
+ else if (ldb < max((INTEGER) 1, m))
+ info = 11;
+ if (info != 0) {
+ Mxerbla("Rtrsm ", info);
+ return;
+ }
+//quick return if possible.
+ if (m == 0 || n == 0)
+ return;
+
+//and when alpha==zero.
+ if (alpha == Zero) {
+ for (j = 0; j < n; j++) {
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = Zero;
+ }
+ }
+ return;
+ }
+//start the operations.
+ if (lside) {
+ if (Mlsame(transa, "N")) {
+//Form B := alpha*inv(A)*B.
+ if (upper) {
+ for (j = 0; j < n; j++) {
+ if (alpha != One) {
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = alpha * B[i + j * ldb];
+ }
+ }
+ for (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 (i = 0; i < k; i++) {
+ B[i + j * ldb] = B[i + j * ldb] - B[k + j * ldb] * A[i + k * lda];
+ }
+ }
+ }
+ }
+ } else {
+ for (j = 0; j < n; j++) {
+ if (alpha != One) {
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = alpha * B[i + j * ldb];
+ }
+ }
+ for (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 (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 (j = 0; j < n; j++) {
+ for (i = 0; i < m; i++) {
+ temp = alpha * B[i + j * ldb];
+ for (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 (j = 0; j < n; j++) {
+ for (i = m - 1; i >= 0; i--) {
+ temp = alpha * B[i + j * ldb];
+ for (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(transa, "N")) {
+//Form B := alpha*B*inv(A).
+ if (upper) {
+ for (j = 0; j < n; j++) {
+ if (alpha != One) {
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = alpha * B[i + j * ldb];
+ }
+ }
+ for (k = 0; k < j; k++) {
+ if (A[k + j * lda] != Zero) {
+ for (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 (i = 0; i < m; i++) {
+ B[i + j * ldb] = temp * B[i + j * ldb];
+ }
+ }
+ }
+ } else {
+ for (j = n - 1; j >= 0; j--) {
+ if (alpha != One) {
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = alpha * B[i + j * ldb];
+ }
+ }
+ for (k = j + 1; k < n; k++) {
+ if (A[k + j * lda] != Zero) {
+ for (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 (i = 0; i < m; i++) {
+ B[i + j * ldb] = temp * B[i + j * ldb];
+ }
+ }
+ }
+ }
+ } else {
+//Form B := alpha*B*inv(A').
+ if (upper) {
+ for (k = n - 1; k >= 0; k--) {
+ if (nounit) {
+ temp = One / A[k + k * lda];
+ for (i = 0; i < m; i++) {
+ B[i + k * ldb] = temp * B[i + k * ldb];
+ }
+ }
+ for (j = 0; j < k; j++) {
+ if (A[j + k * lda] != Zero) {
+ temp = A[j + k * lda];
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = B[i + j * ldb] - temp * B[i + k * ldb];
+ }
+ }
+ }
+ if (alpha != One) {
+ for (i = 0; i < m; i++) {
+ B[i + k * ldb] = alpha * B[i + k * ldb];
+ }
+ }
+ }
+ } else {
+ for (k = 0; k < n; k++) {
+ if (nounit) {
+ temp = One / A[k + k * lda];
+ for (i = 0; i < m; i++) {
+ B[i + k * ldb] = temp * B[i + k * ldb];
+ }
+ }
+ for (j = k + 1; j < n; j++) {
+ if (A[j + k * lda] != Zero) {
+ temp = A[j + k * lda];
+ for (i = 0; i < m; i++) {
+ B[i + j * ldb] = B[i + j * ldb] - temp * B[i + k * ldb];
+ }
+ }
+ }
+ if (alpha != One) {
+ for (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..350aefa
--- /dev/null
+++ b/mpack/Rtrsv.cpp
@@ -0,0 +1,185 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: Rtrsv.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: Rtrsv.cpp,v 1.5 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/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.h>
+
+void Rtrsv(const char *uplo, const char *trans, const char *diag, INTEGER n, REAL * A, INTEGER lda, REAL * x, INTEGER incx)
+{
+ INTEGER i, ix, j, jx, kx, info, nounit;
+ REAL Zero = 0.0;
+ REAL temp;
+
+//Test the input parameters.
+ info = 0;
+ if (!Mlsame(uplo, "U") && !Mlsame(uplo, "L"))
+ info = 1;
+ else if (!Mlsame(trans, "N") && !Mlsame(trans, "T") && !Mlsame(trans, "C"))
+ info = 2;
+ else if (!Mlsame(diag, "U") && !Mlsame(diag, "N"))
+ info = 3;
+ else if (n < 0)
+ info = 4;
+ else if (lda < max((INTEGER) 1, n))
+ info = 6;
+ else if (incx == 0)
+ info = 8;
+ if (info != 0) {
+ Mxerbla("Rtrsv ", info);
+ return;
+ }
+//quick return if possible.
+ if (n == 0)
+ return;
+
+ nounit = Mlsame(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(trans, "N")) {
+//form x := inv(A)*x.
+ if (Mlsame(uplo, "U")) {
+ jx = kx + (n - 1) * incx;
+ for (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 (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 (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 (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(uplo, "U")) {
+ jx = kx;
+ for (j = 0; j < n; j++) {
+ ix = kx;
+ temp = x[jx];
+ for (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 (j = n - 1; j >= 0; j--) {
+ ix = kx;
+ temp = x[jx];
+ for (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..07e0e1c
--- /dev/null
+++ b/mpack/iMlaenv.cpp
@@ -0,0 +1,283 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: iMlaenv.cpp,v 1.12 2010/08/19 01:20:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+
+$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.h>
+#include <mlapack.h>
+#include <string.h>
+#include <ctype.h>
+#include <stdio.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.
+
+INTEGER iMlaenv1(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ INTEGER nb = 1;
+#if !defined (IMLAENV_DEBUG)
+ if (strcmp(&Mlaname[1], "orgqr") == 0) { nb = 32; return nb; }
+ if (strcmp(&Mlaname[1], "ungqr") == 0) { nb = 32; return nb; }
+ if (strcmp(&Mlaname[1], "orgql") == 0) { nb = 32; return nb; }
+ if (strcmp(&Mlaname[1], "ungql") == 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[0], "rsytrd") == 0) { nb = 32; return nb; }
+ if (strcmp(&Mlaname[0], "chetrd") == 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; }
+ if (strcmp(&Mlaname[1], "lauum") == 0) { nb = 64; return nb; }
+#else
+ if (strcmp(&Mlaname[1], "orgqr") == 0) { nb = 8; return nb; }
+ if (strcmp(&Mlaname[1], "ungqr") == 0) { nb = 8; return nb; }
+ if (strcmp(&Mlaname[1], "orgql") == 0) { nb = 8; return nb; }
+ if (strcmp(&Mlaname[1], "ungql") == 0) { nb = 8; return nb; }
+ if (strcmp(&Mlaname[1], "potrf") == 0) { nb = 8; return nb; }
+ if (strcmp(&Mlaname[1], "trtri") == 0) { nb = 8; return nb; }
+ if (strcmp(&Mlaname[0], "rsytrd") == 0) { nb = 8; return nb; }
+ if (strcmp(&Mlaname[0], "chetrd") == 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; }
+ if (strcmp(&Mlaname[1], "lauum") == 0) { nb = 8; return nb; }
+#endif
+ return nb;
+}
+
+//ISPEC = 2: minimum block size
+INTEGER iMlaenv2(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ INTEGER nbmin = 1;
+ if (strcmp(&Mlaname[1], "orgqr") == 0) { nbmin = 2; return nbmin; }
+ if (strcmp(&Mlaname[1], "ungqr") == 0) { nbmin = 2; return nbmin; }
+ if (strcmp(&Mlaname[1], "orgql") == 0) { nbmin = 2; return nbmin; }
+ if (strcmp(&Mlaname[1], "ungql") == 0) { nbmin = 2; return nbmin; }
+ if (strcmp(&Mlaname[1], "trtri") == 0) { nbmin = 2; return nbmin; }
+ if (strcmp(&Mlaname[0], "rsytrd") == 0) { nbmin = 2; return nbmin; }
+ if (strcmp(&Mlaname[0], "chetrd") == 0) { nbmin = 2; return nbmin; }
+ if (strcmp(&Mlaname[1], "getri") == 0) { nbmin = 2; return nbmin; }
+ return nbmin;
+}
+
+//ISPEC = 3: crossover point
+INTEGER iMlaenv3(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ INTEGER nx = 1;
+#if !defined (IMLAENV_DEBUG)
+ if (strcmp(&Mlaname[1], "orgqr") == 0) { nx = 128; return nx; }
+ if (strcmp(&Mlaname[1], "ungqr") == 0) { nx = 128; return nx; }
+ if (strcmp(&Mlaname[1], "orgql") == 0) { nx = 128; return nx; }
+ if (strcmp(&Mlaname[1], "ungql") == 0) { nx = 128; return nx; }
+ if (strcmp(&Mlaname[0], "rsytrd") == 0) { nx = 32; return nx; }
+ if (strcmp(&Mlaname[0], "chetrd") == 0) { nx = 32; return nx; }
+#else
+ if (strcmp(&Mlaname[1], "orgqr") == 0) { nx = 6; return nx; }
+ if (strcmp(&Mlaname[1], "ungqr") == 0) { nx = 6; return nx; }
+ if (strcmp(&Mlaname[1], "orgql") == 0) { nx = 6; return nx; }
+ if (strcmp(&Mlaname[1], "ungql") == 0) { nx = 6; return nx; }
+ if (strcmp(&Mlaname[0], "rsytrd") == 0) { nx = 6; return nx; }
+ if (strcmp(&Mlaname[0], "chetrd") == 0) { nx = 6; return nx; }
+#endif
+ return nx;
+}
+
+INTEGER iMlaenv4(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv5(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv6(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv7(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv8(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv9(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv10(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv11(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv12(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv13(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv14(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv15(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv16(const char *Mlaname, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ return 1;
+}
+
+INTEGER iMlaenv(INTEGER ispec, const char *name, const char *opts, INTEGER n1, INTEGER n2, INTEGER n3, INTEGER n4)
+{
+ INTEGER iret, i, up, len;
+ iret = -1;
+ char Mlaname[MLANAMESIZE + 1] = "000000";
+//buggy
+ len = strlen(name);
+ strncpy(Mlaname, name, (len > MLANAMESIZE) ? MLANAMESIZE : len);
+ for (i = 0; i < MLANAMESIZE; i++) {
+ up = tolower(Mlaname[i]);
+ Mlaname[i] = up;
+ }
+ Mlaname[MLANAMESIZE] = '\0';
+
+ if (!Mlsame(Mlaname, "r") && !Mlsame(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/iRamax.cpp b/mpack/iRamax.cpp
new file mode 100644
index 0000000..5a9f1cf
--- /dev/null
+++ b/mpack/iRamax.cpp
@@ -0,0 +1,98 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: iRamax.cpp,v 1.8 2010/08/07 05:50:10 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+/*
+Copyright (c) 1992-2007 The University of Tennessee. All rights reserved.
+ *
+ * $Id: iRamax.cpp,v 1.8 2010/08/07 05:50:10 nakatamaho Exp $
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/*
+Based on http://www.netlib.org/blas/idamax.f
+finds the index of element having max. absolute value.
+*/
+
+#include <mblas.h>
+
+INTEGER iRamax(INTEGER n, REAL * dx, INTEGER incx)
+{
+ INTEGER imax = 0;
+ INTEGER i, ix;
+ REAL rmax;
+
+ if (n < 1 || incx <= 0)
+ return imax;
+ if (n == 1) return (INTEGER)1;
+
+ ix = 0;
+ rmax = abs(dx[0]);
+ ix = ix + incx;
+ for (i = 1; i < n; i++) {
+ if (abs(dx[ix]) > rmax) {
+ imax = i;
+ rmax = abs(dx[ix]);
+ }
+ ix = ix + incx;
+ }
+ return imax + 1;
+}
diff --git a/mpack/mblas.h b/mpack/mblas.h
new file mode 100644
index 0000000..579ce5d
--- /dev/null
+++ b/mpack/mblas.h
@@ -0,0 +1,91 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: mblas.h,v 1.17 2010/08/07 03:15:46 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+
+#ifndef _MBLAS_H_
+#define _MBLAS_H_
+
+#define ___MPACK_DEFAULT_PRECISION___ 512
+
+#if defined ___MPACK_BUILD_WITH_MPFR___
+#include <mblas_mpfr.h>
+typedef mpackint INTEGER;
+typedef mpreal REAL;
+#define Mlsame Mlsame_mpfr
+#define Mxerbla Mxerbla_mpfr
+#endif
+
+#if defined ___MPACK_BUILD_WITH_GMP___
+#include <mblas_gmp.h>
+typedef mpackint INTEGER;
+typedef mpf_class REAL;
+#define Mlsame Mlsame_gmp
+#define Mxerbla Mxerbla_gmp
+#endif
+
+#if defined ___MPACK_BUILD_WITH_QD___
+#include <mblas_qd.h>
+typedef mpackint INTEGER;
+typedef qd_real REAL;
+#define Mlsame Mlsame_qd
+#define Mxerbla Mxerbla_qd
+#endif
+
+#if defined ___MPACK_BUILD_WITH_DD___
+#include <mblas_dd.h>
+typedef mpackint INTEGER;
+typedef dd_real REAL;
+#define Mlsame Mlsame_dd
+#define Mxerbla Mxerbla_dd
+#endif
+
+#if defined ___MPACK_BUILD_WITH_DOUBLE___
+#include <mblas_double.h>
+typedef mpackint INTEGER;
+typedef double REAL;
+#define Mlsame Mlsame_double
+#define Mxerbla Mxerbla_double
+#endif
+
+#if defined ___MPACK_BUILD_WITH___FLOAT128___
+#include <mblas___float128.h>
+typedef mpackint INTEGER;
+typedef __float128 REAL;
+#define Mlsame Mlsame___float128
+#define Mxerbla Mxerbla___float128
+#endif
+
+#include <cstdlib>
+#include <cmath>
+using std::max;
+using std::min;
+using std::abs;
+using std::sqrt;
+
+#endif
diff --git a/mpack/mblas_gmp.h b/mpack/mblas_gmp.h
new file mode 100644
index 0000000..253c18a
--- /dev/null
+++ b/mpack/mblas_gmp.h
@@ -0,0 +1,96 @@
+/*************************************************************************
+ *
+ * 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);
+void Rrot(mpackint n, mpf_class * dx, mpackint incx, mpf_class * dy, mpackint incy, mpf_class c, mpf_class s);
+void Rrotg(mpf_class * da, mpf_class * db, mpf_class * c, mpf_class * s);
+mpackint iRamax(mpackint n, mpf_class * dx, mpackint incx);
+#endif
diff --git a/mpack/mlapack.h b/mpack/mlapack.h
new file mode 100644
index 0000000..cdc8de4
--- /dev/null
+++ b/mpack/mlapack.h
@@ -0,0 +1,107 @@
+/*
+ * Copyright (c) 2008-2010
+ * Nakata, Maho
+ * All rights reserved.
+ *
+ * $Id: mlapack.h,v 1.28 2010/08/07 03:15:46 nakatamaho Exp $
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+
+#ifndef _MLAPACK_H_
+#define _MLAPACK_H_
+
+#if defined ___MPACK_BUILD_WITH_GMP___
+#include <mlapack_gmp.h>
+typedef mpackint INTEGER;
+typedef mpacklogical LOGICAL;
+typedef mpf_class REAL;
+#define Mlsame Mlsame_gmp
+#define Mxerbla Mxerbla_gmp
+#define Rlamch Rlamch_gmp
+#define iMlaenv iMlaenv_gmp
+#endif
+
+#if defined ___MPACK_BUILD_WITH_MPFR___
+#include <mlapack_mpfr.h>
+typedef mpackint INTEGER;
+typedef mpacklogical LOGICAL;
+typedef mpreal REAL;
+#define Mlsame Mlsame_mpfr
+#define Mxerbla Mxerbla_mpfr
+#define Rlamch Rlamch_mpfr
+#define iMlaenv iMlaenv_mpfr
+#endif
+
+#if defined ___MPACK_BUILD_WITH_QD___
+#include <mlapack_qd.h>
+typedef mpackint INTEGER;
+typedef mpacklogical LOGICAL;
+typedef qd_real REAL;
+#if !defined __MUTILS_CPP__
+#define nint __qd_nint
+#endif
+#define Mlsame Mlsame_qd
+#define Mxerbla Mxerbla_qd
+#define Rlamch Rlamch_qd
+#define iMlaenv iMlaenv_qd
+#endif
+
+#if defined ___MPACK_BUILD_WITH_DD___
+#include <mlapack_dd.h>
+typedef mpackint INTEGER;
+typedef mpacklogical LOGICAL;
+typedef dd_real REAL;
+#if !defined __MUTILS_CPP__
+#define nint __dd_nint
+#endif
+#define Mlsame Mlsame_dd
+#define Mxerbla Mxerbla_dd
+#define Rlamch Rlamch_dd
+#define iMlaenv iMlaenv_dd
+#endif
+
+#if defined ___MPACK_BUILD_WITH_DOUBLE___
+#include <mlapack_double.h>
+typedef mpackint INTEGER;
+typedef mpacklogical LOGICAL;
+typedef double REAL;
+#define Mlsame Mlsame_double
+#define Mxerbla Mxerbla_double
+#define Rlamch Rlamch_double
+#define iMlaenv iMlaenv_double
+#endif
+
+#if defined ___MPACK_BUILD_WITH___FLOAT128___
+#include <mlapack___float128.h>
+typedef mpackint INTEGER;
+typedef mpacklogical LOGICAL;
+typedef __float128 REAL;
+#define Mlsame Mlsame___float128
+#define Mxerbla Mxerbla___float128
+#define Rlamch Rlamch___float128
+#define iMlaenv iMlaenv___float128
+#endif
+
+#endif
+
diff --git a/mpack/mlapack_gmp.h b/mpack/mlapack_gmp.h
new file mode 100644
index 0000000..d902d79
--- /dev/null
+++ b/mpack/mlapack_gmp.h
@@ -0,0 +1,96 @@
+/*************************************************************************
+ *
+ * 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);
+void Rgetrf ( mpackint m, mpackint n, mpf_class * A, mpackint lda, mpackint *ipiv, mpackint *info );
+void Rgetrs ( const char *trans, mpackint n, mpackint nrhs, mpf_class * A, mpackint lda, mpackint *ipiv, mpf_class * B, mpackint ldb, mpackint *info );
+void Rlaswp ( mpackint n, mpf_class * A, mpackint lda, mpackint k1, mpackint k2, mpackint *ipiv, mpackint incx );
+void Rgetf2 ( mpackint m, mpackint n, mpf_class * A, mpackint lda, mpackint *ipiv, 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/main.cpp b/src/main.cpp
similarity index 97%
rename from main.cpp
rename to src/main.cpp
index ecd07bb..e8e7a21 100644
--- a/main.cpp
+++ b/src/main.cpp
@@ -824,37 +824,37 @@ public:
}
void addDiagonal(const Real &c) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < blocks.size(); b++)
blocks[b].addDiagonal(c);
}
void operator+=(const BlockDiagonalMatrix &A) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < blocks.size(); b++)
blocks[b] += A.blocks[b];
}
void operator-=(const BlockDiagonalMatrix &A) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < blocks.size(); b++)
blocks[b] -= A.blocks[b];
}
void operator*=(const Real &c) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < blocks.size(); b++)
blocks[b] *= c;
}
void copyFrom(const BlockDiagonalMatrix &A) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < blocks.size(); b++)
blocks[b].copyFrom(A.blocks[b]);
}
void symmetrize() {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < blocks.size(); b++)
blocks[b].symmetrize();
}
@@ -887,9 +887,14 @@ ostream& operator<<(ostream& os, const BlockDiagonalMatrix& A) {
Real frobeniusProductSymmetric(const BlockDiagonalMatrix &A,
const BlockDiagonalMatrix &B) {
Real result = 0;
- // TODO: Parallelize this loop
- for (unsigned int b = 0; b < A.blocks.size(); b++)
- result += frobeniusProductSymmetric(A.blocks[b], B.blocks[b]);
+ // #pragma omp parallel for schedule(dynamic)
+ for (unsigned int b = 0; b < A.blocks.size(); b++) {
+ Real f = frobeniusProductSymmetric(A.blocks[b], B.blocks[b]);
+ // #pragma omp critical
+ {
+ result += f;
+ }
+ }
return result;
}
@@ -901,9 +906,14 @@ Real frobeniusProductOfSums(const BlockDiagonalMatrix &X,
const BlockDiagonalMatrix &Y,
const BlockDiagonalMatrix &dY) {
Real result = 0;
- // TODO: Parallelize this loop
- for (unsigned int b = 0; b < X.blocks.size(); b++)
- result += frobeniusProductOfSums(X.blocks[b], dX.blocks[b], Y.blocks[b], dY.blocks[b]);
+ // #pragma omp parallel for schedule(dynamic)
+ for (unsigned int b = 0; b < X.blocks.size(); b++) {
+ Real f = frobeniusProductOfSums(X.blocks[b], dX.blocks[b], Y.blocks[b], dY.blocks[b]);
+ // #pragma omp critical
+ {
+ result += f;
+ }
+ }
return result;
}
@@ -912,7 +922,7 @@ void blockDiagonalMatrixScaleMultiplyAdd(Real alpha,
BlockDiagonalMatrix &B,
Real beta,
BlockDiagonalMatrix &C) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < A.blocks.size(); b++)
matrixScaleMultiplyAdd(alpha, A.blocks[b], B.blocks[b], beta, C.blocks[b]);
}
@@ -924,7 +934,7 @@ void blockDiagonalMatrixMultiply(BlockDiagonalMatrix &A,
}
void lowerTriangularInverseCongruence(BlockDiagonalMatrix &A, BlockDiagonalMatrix &L) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < A.blocks.size(); b++)
lowerTriangularInverseCongruence(A.blocks[b], L.blocks[b]);
}
@@ -941,10 +951,10 @@ Real minEigenvalue(BlockDiagonalMatrix &A, vector<Vector> &workspace, vector<Vec
// TODO: get rid of this hack
Real lambdaMin = 1e100;
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < A.blocks.size(); b++) {
Real minBlockLambda = minEigenvalue(A.blocks[b], workspace[b], eigenvalues[b]);
- #pragma omp critical
+ // #pragma omp critical
{
lambdaMin = min(lambdaMin, minBlockLambda);
}
@@ -955,38 +965,38 @@ Real minEigenvalue(BlockDiagonalMatrix &A, vector<Vector> &workspace, vector<Vec
void choleskyDecomposition(BlockDiagonalMatrix &A,
BlockDiagonalMatrix &L) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < A.blocks.size(); b++)
choleskyDecomposition(A.blocks[b], L.blocks[b]);
}
void blockMatrixSolveWithCholesky(BlockDiagonalMatrix &ACholesky,
BlockDiagonalMatrix &X) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < X.blocks.size(); b++)
matrixSolveWithCholesky(ACholesky.blocks[b], X.blocks[b]);
}
void blockMatrixLowerTriangularSolve(BlockDiagonalMatrix &L, Matrix &B) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < L.blocks.size(); b++)
lowerTriangularSolve(L.blocks[b], &B.elt(L.blockStartIndices[b], 0), B.cols, B.rows);
}
void blockMatrixLowerTriangularTransposeSolve(BlockDiagonalMatrix &L, Matrix &B) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < L.blocks.size(); b++)
lowerTriangularTransposeSolve(L.blocks[b], &B.elt(L.blockStartIndices[b], 0), B.cols, B.rows);
}
void blockMatrixLowerTriangularSolve(BlockDiagonalMatrix &L, Vector &v) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < L.blocks.size(); b++)
lowerTriangularSolve(L.blocks[b], &v[L.blockStartIndices[b]], 1, v.size());
}
void blockMatrixLowerTriangularTransposeSolve(BlockDiagonalMatrix &L, Vector &v) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < L.blocks.size(); b++)
lowerTriangularTransposeSolve(L.blocks[b], &v[L.blockStartIndices[b]], 1, v.size());
}
@@ -1456,7 +1466,7 @@ void computeBilinearPairings(const BlockDiagonalMatrix &A,
const vector<Matrix> &bilinearBases,
vector<Matrix> &workspace,
BlockDiagonalMatrix &result) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < bilinearBases.size(); b++)
tensorMatrixCongruenceTranspose(A.blocks[b], bilinearBases[b], workspace[b], result.blocks[b]);
}
@@ -1465,7 +1475,7 @@ void computeInvBilinearPairingsWithCholesky(const BlockDiagonalMatrix &L,
const vector<Matrix> &bilinearBases,
vector<Matrix> &workspace,
BlockDiagonalMatrix &result) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int b = 0; b < bilinearBases.size(); b++)
tensorMatrixInvCongruenceTransposeWithCholesky(L.blocks[b], bilinearBases[b], workspace[b], result.blocks[b]);
}
@@ -1530,7 +1540,7 @@ void computeSchurBlocks(const SDP &sdp,
const BlockDiagonalMatrix &BilinearPairingsY,
BlockDiagonalMatrix &SchurBlocks) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int j = 0; j < sdp.dimensions.size(); j++) {
const int ej = sdp.degrees[j] + 1;
@@ -1572,7 +1582,8 @@ void basicCompletion(const Vector &dualObjectiveReduced,
assert((int)basicIndices.size() == FreeVarMatrixReduced.cols);
assert((int)nonBasicIndices.size() == FreeVarMatrixReduced.rows);
assert((int)x.size() == FreeVarMatrixReduced.cols + FreeVarMatrixReduced.rows);
-
+
+ // #pragma omp parallel for schedule(static)
for (unsigned int n = 0; n < basicIndices.size(); n++) {
x[basicIndices[n]] = dualObjectiveReduced[n];
for (unsigned int p = 0; p < nonBasicIndices.size(); p++)
@@ -1591,6 +1602,7 @@ void nonBasicShift(const Matrix &FreeVarMatrixReduced,
assert((int)x.size() == FreeVarMatrixReduced.cols + FreeVarMatrixReduced.rows);
assert(nonBasicIndices.size() == xReduced.size());
+ // #pragma omp parallel for schedule(static)
for (unsigned int p = 0; p < nonBasicIndices.size(); p++) {
xReduced[p] = x[nonBasicIndices[p]];
for (unsigned int n = 0; n < basicIndices.size(); n++)
@@ -1602,7 +1614,7 @@ void computeDualResidues(const SDP &sdp,
const BlockDiagonalMatrix &Y,
const BlockDiagonalMatrix &BilinearPairingsY,
Vector &dualResidues) {
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int j = 0; j < sdp.dimensions.size(); j++) {
const int ej = sdp.degrees[j] +1;
@@ -1652,7 +1664,7 @@ void computeSchurRHS(const SDP &sdp,
for (unsigned int p = 0; p < r.size(); p++)
r[p] = -dualResidues[p];
- #pragma omp parallel for schedule(dynamic)
+ // #pragma omp parallel for schedule(dynamic)
for (unsigned int j = 0; j < sdp.dimensions.size(); j++) {
for (vector<IndexTuple>::const_iterator t = sdp.constraintIndices[j].begin();
t != sdp.constraintIndices[j].end();
@@ -2107,10 +2119,6 @@ void testMatrix() {
cout << A << endl;
}
-const char *help(const char *cmd) {
- return cmd;
-}
-
namespace po = boost::program_options;
int main(int argc, char** argv) {
diff --git a/tinyxml2.cpp b/src/tinyxml2.cpp
similarity index 100%
rename from tinyxml2.cpp
rename to src/tinyxml2.cpp
diff --git a/tinyxml2.h b/src/tinyxml2.h
similarity index 100%
rename from tinyxml2.h
rename to src/tinyxml2.h
diff --git a/types.h b/src/types.h
similarity index 81%
rename from types.h
rename to src/types.h
index 1017cf8..852aab7 100644
--- a/types.h
+++ b/src/types.h
@@ -1,8 +1,8 @@
#ifndef SDP_BOOTSTRAP_TYPES_H_
#define SDP_BOOTSTRAP_TYPES_H_
-#include <mblas_gmp.h>
-#include <mlapack_gmp.h>
+#include <mblas.h>
+#include <mlapack.h>
typedef mpackint Integer;
typedef mpf_class Real;
--
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