Created tag 2.3.0.

An example error:
Cannot generate a safe linker search path for target tod_ectomodule because
  files in some directories may conflict with libraries in implicit
  directories

3rdparty/CMakeLists.txt

@@ -1,22 +1,18 @@
-if(ANDROID)
- configure_file("${CMAKE_SOURCE_DIR}/Android.mk.modules.in" "${CMAKE_CURRENT_BINARY_DIR}/Android.mk")
+if(NOT ZLIB_FOUND)
+    add_subdirectory(zlib)
 endif()
-
-add_subdirectory(lapack)
-add_subdirectory(zlib)
 if(WITH_JASPER AND NOT JASPER_FOUND)
-	add_subdirectory(libjasper)
+    add_subdirectory(libjasper)
 endif()
 if(WITH_JPEG AND NOT JPEG_FOUND)
-	add_subdirectory(libjpeg)
+    add_subdirectory(libjpeg)
 endif()
 if(WITH_PNG AND NOT PNG_FOUND)
-	add_subdirectory(libpng)
+    add_subdirectory(libpng)
 endif()
 if(WITH_TIFF AND NOT TIFF_FOUND)
-	add_subdirectory(libtiff)
+    add_subdirectory(libtiff)
 endif()
-
-if(0)
-add_subdirectory(gtest)
+if(WIN32)
+    add_subdirectory(ffmpeg)
 endif()

3rdparty/ffmpeg/CMakeLists.txt

@@ -0,0 +1,20 @@
+project(opencv_ffmpeg)
+
+if(MSVC64 OR MINGW64)
+   set(FFMPEG_SUFFIX _64)
+endif()
+
+set(module_bare_name "opencv_ffmpeg${FFMPEG_SUFFIX}.dll")
+set(module_name "${CMAKE_CURRENT_SOURCE_DIR}/${module_bare_name}")
+
+get_target_property(bin_dir opencv_traincascade LOCATION)
+get_filename_component(bin_dir ${bin_dir} PATH) 
+
+message(STATUS "ffmpeg output dir: ${bin_dir}")
+
+add_custom_target(opencv_ffmpeg ALL
+                  COMMAND ${CMAKE_COMMAND} -E copy
+                    ${module_name} ${bin_dir}/${module_bare_name}
+                  COMMENT "Copying ${module_name} to the output directory")
+
+install(FILES ${module_name} DESTINATION bin COMPONENT main)

3rdparty/ffmpeg/ffopencv.c

@@ -0,0 +1 @@
+#include "cap_ffmpeg_impl.hpp"

3rdparty/ffmpeg/make.bat

@@ -0,0 +1,2 @@
+gcc -Wall -shared -o opencv_ffmpeg.dll -O2 -x c++ -I../include -I../include/ffmpeg_ -I../../modules/highgui/src ffopencv.c -L../lib -lavformat -lavcodec -lavdevice -lswscale -lavutil -lwsock32
+set path=c:\apps\mingw64\bin;%path% & gcc -Wall -shared -o opencv_ffmpeg_64.dll -O2 -x c++ -I../include -I../include/ffmpeg_ -I../../modules/highgui/src ffopencv.c -L../lib -lavformat64 -lavcodec64 -lavdevice64 -lswscale64 -lavutil64 -lavcore64 -lwsock32

3rdparty/ffmpeg/readme.txt

@@ -0,0 +1,9 @@
+The build script is to be fixed.
+Right now it assumes that 32-bit MinGW is in the system path and
+64-bit mingw is installed to c:\Apps\MinGW64.
+
+It is important that gcc is used, not g++!
+Otherwise the produced DLL will likely be dependent on libgcc_s_dw2-1.dll or similar DLL.
+While we want to make the DLLs with minimum dependencies: Win32 libraries + msvcrt.dll.
+
+ffopencv.c is really a C++ source, hence -x c++ is used.

3rdparty/gtest/CMakeLists.txt

@@ -1,29 +0,0 @@
-project(opencv_gtest)
-
-# List of C++ files:
-
-include_directories("${CMAKE_CURRENT_SOURCE_DIR}/..")
-
-# The .cpp files:
-file(GLOB lib_srcs *.cpp)
-file(GLOB lib_hdrs *.h)
-
-# ----------------------------------------------------------------------------------
-# 				Define the library target:
-# ----------------------------------------------------------------------------------
-
-set(the_target "opencv_gtest")
-
-add_library(${the_target} STATIC ${lib_srcs} ${lib_hdrs})
-
-if(UNIX)
-     if(CMAKE_COMPILER_IS_GNUCXX OR CV_ICC)
-        set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -fPIC")
-     endif()
-endif()
-
-set_target_properties(${the_target}
-	PROPERTIES OUTPUT_NAME "${the_target}"
-	DEBUG_POSTFIX "${OPENCV_DEBUG_POSTFIX}"
-	ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/3rdparty/lib
-	)

3rdparty/gtest/README

@@ -1,417 +0,0 @@
-Google C++ Testing Framework
-============================
-
-http://code.google.com/p/googletest/
-
-Overview
---------
-
-Google's framework for writing C++ tests on a variety of platforms
-(Linux, Mac OS X, Windows, Windows CE, Symbian, etc).  Based on the
-xUnit architecture.  Supports automatic test discovery, a rich set of
-assertions, user-defined assertions, death tests, fatal and non-fatal
-failures, various options for running the tests, and XML test report
-generation.
-
-Please see the project page above for more information as well as the
-mailing list for questions, discussions, and development.  There is
-also an IRC channel on OFTC (irc.oftc.net) #gtest available.  Please
-join us!
-
-Requirements for End Users
---------------------------
-
-Google Test is designed to have fairly minimal requirements to build
-and use with your projects, but there are some.  Currently, we support
-Linux, Windows, Mac OS X, and Cygwin.  We will also make our best
-effort to support other platforms (e.g. Solaris, AIX, and z/OS).
-However, since core members of the Google Test project have no access
-to these platforms, Google Test may have outstanding issues there.  If
-you notice any problems on your platform, please notify
-googletestframework@googlegroups.com.  Patches for fixing them are
-even more welcome!
-
-### Linux Requirements ###
-
-These are the base requirements to build and use Google Test from a source
-package (as described below):
-  * GNU-compatible Make or gmake
-  * POSIX-standard shell
-  * POSIX(-2) Regular Expressions (regex.h)
-  * A C++98-standard-compliant compiler
-
-### Windows Requirements ###
-
-  * Microsoft Visual C++ 7.1 or newer
-
-### Cygwin Requirements ###
-
-  * Cygwin 1.5.25-14 or newer
-
-### Mac OS X Requirements ###
-
-  * Mac OS X 10.4 Tiger or newer
-  * Developer Tools Installed
-
-Also, you'll need CMake 2.6.4 or higher if you want to build the
-samples using the provided CMake script, regardless of the platform.
-
-Requirements for Contributors
------------------------------
-
-We welcome patches.  If you plan to contribute a patch, you need to
-build Google Test and its own tests from an SVN checkout (described
-below), which has further requirements:
-
-  * Python version 2.3 or newer (for running some of the tests and
-    re-generating certain source files from templates)
-  * CMake 2.6.4 or newer
-
-Getting the Source
-------------------
-
-There are two primary ways of getting Google Test's source code: you
-can download a stable source release in your preferred archive format,
-or directly check out the source from our Subversion (SVN) repositary.
-The SVN checkout requires a few extra steps and some extra software
-packages on your system, but lets you track the latest development and
-make patches much more easily, so we highly encourage it.
-
-### Source Package ###
-
-Google Test is released in versioned source packages which can be
-downloaded from the download page [1].  Several different archive
-formats are provided, but the only difference is the tools used to
-manipulate them, and the size of the resulting file.  Download
-whichever you are most comfortable with.
-
-  [1] http://code.google.com/p/googletest/downloads/list
-
-Once the package is downloaded, expand it using whichever tools you
-prefer for that type.  This will result in a new directory with the
-name "gtest-X.Y.Z" which contains all of the source code.  Here are
-some examples on Linux:
-
-  tar -xvzf gtest-X.Y.Z.tar.gz
-  tar -xvjf gtest-X.Y.Z.tar.bz2
-  unzip gtest-X.Y.Z.zip
-
-### SVN Checkout ###
-
-To check out the main branch (also known as the "trunk") of Google
-Test, run the following Subversion command:
-
-  svn checkout http://googletest.googlecode.com/svn/trunk/ gtest-svn
-
-Setting up the Build
---------------------
-
-To build Google Test and your tests that use it, you need to tell your
-build system where to find its headers and source files.  The exact
-way to do it depends on which build system you use, and is usually
-straightforward.
-
-### Generic Build Instructions ###
-
-Suppose you put Google Test in directory ${GTEST_DIR}.  To build it,
-create a library build target (or a project as called by Visual Studio
-and Xcode) to compile
-
-  ${GTEST_DIR}/src/gtest-all.cc
-
-with
-
-  ${GTEST_DIR}/include and ${GTEST_DIR}
-
-in the header search path.  Assuming a Linux-like system and gcc,
-something like the following will do:
-
-  g++ -I${GTEST_DIR}/include -I${GTEST_DIR} -c ${GTEST_DIR}/src/gtest-all.cc
-  ar -rv libgtest.a gtest-all.o
-
-Next, you should compile your test source file with
-${GTEST_DIR}/include in the header search path, and link it with gtest
-and any other necessary libraries:
-
-  g++ -I${GTEST_DIR}/include path/to/your_test.cc libgtest.a -o your_test
-
-As an example, the make/ directory contains a Makefile that you can
-use to build Google Test on systems where GNU make is available
-(e.g. Linux, Mac OS X, and Cygwin).  It doesn't try to build Google
-Test's own tests.  Instead, it just builds the Google Test library and
-a sample test.  You can use it as a starting point for your own build
-script.
-
-If the default settings are correct for your environment, the
-following commands should succeed:
-
-  cd ${GTEST_DIR}/make
-  make
-  ./sample1_unittest
-
-If you see errors, try to tweak the contents of make/Makefile to make
-them go away.  There are instructions in make/Makefile on how to do
-it.
-
-### Using CMake ###
-
-Google Test comes with a CMake build script (CMakeLists.txt) that can
-be used on a wide range of platforms ("C" stands for cross-platofrm.).
-If you don't have CMake installed already, you can download it for
-free from http://www.cmake.org/.
-
-CMake works by generating native makefiles or build projects that can
-be used in the compiler environment of your choice.  The typical
-workflow starts with:
-
-  mkdir mybuild       # Create a directory to hold the build output.
-  cd mybuild
-  cmake ${GTEST_DIR}  # Generate native build scripts.
-
-If you want to build Google Test's samples, you should replace the
-last command with
-
-  cmake -Dbuild_gtest_samples=ON ${GTEST_DIR}
-
-If you are on a *nix system, you should now see a Makefile in the
-current directory.  Just type 'make' to build gtest.
-
-If you use Windows and have Vistual Studio installed, a gtest.sln file
-and several .vcproj files will be created.  You can then build them
-using Visual Studio.
-
-On Mac OS X with Xcode installed, a .xcodeproj file will be generated.
-
-### Legacy Build Scripts ###
-
-Before settling on CMake, we have been providing hand-maintained build
-projects/scripts for Visual Studio, Xcode, and Autotools.  While we
-continue to provide them for convenience, they are not actively
-maintained any more.  We highly recommend that you follow the
-instructions in the previous two sections to integrate Google Test
-with your existing build system.
-
-If you still need to use the legacy build scripts, here's how:
-
-The msvc\ folder contains two solutions with Visual C++ projects.
-Open the gtest.sln or gtest-md.sln file using Visual Studio, and you
-are ready to build Google Test the same way you build any Visual
-Studio project.  Files that have names ending with -md use DLL
-versions of Microsoft runtime libraries (the /MD or the /MDd compiler
-option).  Files without that suffix use static versions of the runtime
-libraries (the /MT or the /MTd option).  Please note that one must use
-the same option to compile both gtest and the test code.  If you use
-Visual Studio 2005 or above, we recommend the -md version as /MD is
-the default for new projects in these versions of Visual Studio.
-
-On Mac OS X, open the gtest.xcodeproj in the xcode/ folder using
-Xcode.  Build the "gtest" target.  The universal binary framework will
-end up in your selected build directory (selected in the Xcode
-"Preferences..." -> "Building" pane and defaults to xcode/build).
-Alternatively, at the command line, enter:
-
-  xcodebuild
-
-This will build the "Release" configuration of gtest.framework in your
-default build location.  See the "xcodebuild" man page for more
-information about building different configurations and building in
-different locations.
-
-Tweaking Google Test
---------------------
-
-Google Test can be used in diverse environments.  The default
-configuration may not work (or may not work well) out of the box in
-some environments.  However, you can easily tweak Google Test by
-defining control macros on the compiler command line.  Generally,
-these macros are named like GTEST_XYZ and you define them to either 1
-or 0 to enable or disable a certain feature.
-
-We list the most frequently used macros below.  For a complete list,
-see file include/gtest/internal/gtest-port.h.
-
-### Choosing a TR1 Tuple Library ###
-
-Some Google Test features require the C++ Technical Report 1 (TR1)
-tuple library, which is not yet available with all compilers.  The
-good news is that Google Test implements a subset of TR1 tuple that's
-enough for its own need, and will automatically use this when the
-compiler doesn't provide TR1 tuple.
-
-Usually you don't need to care about which tuple library Google Test
-uses.  However, if your project already uses TR1 tuple, you need to
-tell Google Test to use the same TR1 tuple library the rest of your
-project uses, or the two tuple implementations will clash.  To do
-that, add
-
-  -DGTEST_USE_OWN_TR1_TUPLE=0
-
-to the compiler flags while compiling Google Test and your tests.  If
-you want to force Google Test to use its own tuple library, just add
-
-  -DGTEST_USE_OWN_TR1_TUPLE=1
-
-to the compiler flags instead.
-
-If you don't want Google Test to use tuple at all, add
-
-  -DGTEST_HAS_TR1_TUPLE=0
-
-and all features using tuple will be disabled.
-
-### Multi-threaded Tests ###
-
-Google Test is thread-safe where the pthread library is available.
-After #include <gtest/gtest.h>, you can check the GTEST_IS_THREADSAFE
-macro to see whether this is the case (yes if the macro is #defined to
-1, no if it's undefined.).
-
-If Google Test doesn't correctly detect whether pthread is available
-in your environment, you can force it with
-
-  -DGTEST_HAS_PTHREAD=1
-
-or
-
-  -DGTEST_HAS_PTHREAD=0
-
-When Google Test uses pthread, you may need to add flags to your
-compiler and/or linker to select the pthread library, or you'll get
-link errors.  If you use the CMake script or the deprecated Autotools
-script, this is taken care of for you.  If you use your own build
-script, you'll need to read your compiler and linker's manual to
-figure out what flags to add.
-
-### As a Shared Library (DLL) ###
-
-Google Test is compact, so most users can build and link it as a
-static library for the simplicity.  You can choose to use Google Test
-as a shared library (known as a DLL on Windows) if you prefer.
-
-To compile gtest as a shared library, add
-
-  -DGTEST_CREATE_SHARED_LIBRARY=1
-
-to the compiler flags.  You'll also need to tell the linker to produce
-a shared library instead - consult your linker's manual for how to do
-it.
-
-To compile your tests that use the gtest shared library, add
-
-  -DGTEST_LINKED_AS_SHARED_LIBRARY=1
-
-to the compiler flags.
-
-### Avoiding Macro Name Clashes ###
-
-In C++, macros don't obey namespaces.  Therefore two libraries that
-both define a macro of the same name will clash if you #include both
-definitions.  In case a Google Test macro clashes with another
-library, you can force Google Test to rename its macro to avoid the
-conflict.
-
-Specifically, if both Google Test and some other code define macro
-FOO, you can add
-
-  -DGTEST_DONT_DEFINE_FOO=1
-
-to the compiler flags to tell Google Test to change the macro's name
-from FOO to GTEST_FOO.  Currently FOO can be FAIL, SUCCEED, or TEST.
-For example, with -DGTEST_DONT_DEFINE_TEST=1, you'll need to write
-
-  GTEST_TEST(SomeTest, DoesThis) { ... }
-
-instead of
-
-  TEST(SomeTest, DoesThis) { ... }
-
-in order to define a test.
-
-Upgrating from an Earlier Version
----------------------------------
-
-We strive to keep Google Test releases backward compatible.
-Sometimes, though, we have to make some breaking changes for the
-users' long-term benefits.  This section describes what you'll need to
-do if you are upgrading from an earlier version of Google Test.
-
-### Upgrading from 1.3.0 or Earlier ###
-
-You may need to explicitly enable or disable Google Test's own TR1
-tuple library.  See the instructions in section "Choosing a TR1 Tuple
-Library".
-
-### Upgrading from 1.4.0 or Earlier ###
-
-The Autotools build script (configure + make) is no longer officially
-supportted.  You are encouraged to migrate to your own build system or
-use CMake.  If you still need to use Autotools, you can find
-instructions in the README file from Google Test 1.4.0.
-
-On platforms where the pthread library is available, Google Test uses
-it in order to be thread-safe.  See the "Multi-threaded Tests" section
-for what this means to your build script.
-
-If you use Microsoft Visual C++ 7.1 with exceptions disabled, Google
-Test will no longer compile.  This should affect very few people, as a
-large portion of STL (including <string>) doesn't compile in this mode
-anyway.  We decided to stop supporting it in order to greatly simplify
-Google Test's implementation.
-
-Developing Google Test
-----------------------
-
-This section discusses how to make your own changes to Google Test.
-
-### Testing Google Test Itself ###
-
-To make sure your changes work as intended and don't break existing
-functionality, you'll want to compile and run Google Test's own tests.
-For that you can use CMake:
-
-  mkdir mybuild
-  cd mybuild
-  cmake -Dbuild_all_gtest_tests=ON ${GTEST_DIR}
-
-Make sure you have Python installed, as some of Google Test's tests
-are written in Python.  If the cmake command complains about not being
-able to find Python ("Could NOT find PythonInterp (missing:
-PYTHON_EXECUTABLE)"), try telling it explicitly where your Python
-executable can be found:
-
-  cmake -DPYTHON_EXECUTABLE=path/to/python -Dbuild_all_gtest_tests=ON \
-      ${GTEST_DIR}
-
-Next, you can build Google Test and all of its own tests.  On *nix,
-this is usually done by 'make'.  To run the tests, do
-
-  make test
-
-All tests should pass.
-
-### Regenerating Source Files ###
-
-Some of Google Test's source files are generated from templates (not
-in the C++ sense) using a script.  A template file is named FOO.pump,
-where FOO is the name of the file it will generate.  For example, the
-file include/gtest/internal/gtest-type-util.h.pump is used to generate
-gtest-type-util.h in the same directory.
-
-Normally you don't need to worry about regenerating the source files,
-unless you need to modify them.  In that case, you should modify the
-corresponding .pump files instead and run the pump.py Python script to
-regenerate them.  You can find pump.py in the scripts/ directory.
-Read the Pump manual [2] for how to use it.
-
-  [2] http://code.google.com/p/googletest/wiki/PumpManual
-
-### Contributing a Patch ###
-
-We welcome patches.  Please read the Google Test developer's guide [3]
-for how you can contribute.  In particular, make sure you have signed
-the Contributor License Agreement, or we won't be able to accept the
-patch.
-
-  [3] http://code.google.com/p/googletest/wiki/GoogleTestDevGuide
-
-Happy testing!

3rdparty/include/cblas.h

@@ -1,100 +0,0 @@
-/* CLAPACK 3.0 BLAS wrapper macros and functions
- * Feb 5, 2000
- */
-
-#ifndef __CBLAS_H
-#define __CBLAS_H
-
-#include "f2c.h"
-
-#if defined _MSC_VER && _MSC_VER >= 1400
-#pragma warning(disable: 4244 4554)
-#endif
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-static __inline double r_lg10(real *x)
-{
-    return 0.43429448190325182765*log(*x);
-}
-
-static __inline double d_lg10(doublereal *x)
-{
-    return 0.43429448190325182765*log(*x);
-}
-
-static __inline double d_sign(doublereal *a, doublereal *b)
-{
-    double x = fabs(*a);
-    return *b >= 0 ? x : -x;
-}
-
-static __inline double r_sign(real *a, real *b)
-{
-    double x = fabs((double)*a);
-    return *b >= 0 ? x : -x;
-}
-
-extern const unsigned char lapack_toupper_tab[];
-#define lapack_toupper(c) ((char)lapack_toupper_tab[(unsigned char)(c)])
-
-extern const unsigned char lapack_lamch_tab[];
-extern const doublereal lapack_dlamch_tab[];
-extern const doublereal lapack_slamch_tab[];
-    
-static __inline logical lsame_(char *ca, char *cb)
-{
-    return lapack_toupper(ca[0]) == lapack_toupper(cb[0]);
-}
-
-static __inline doublereal dlamch_(char* cmach)
-{
-    return lapack_dlamch_tab[lapack_lamch_tab[(unsigned char)cmach[0]]];
-}
-    
-static __inline doublereal slamch_(char* cmach)
-{
-    return lapack_slamch_tab[lapack_lamch_tab[(unsigned char)cmach[0]]];
-}    
-    
-static __inline integer i_nint(real *x)
-{
-    return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
-}
-
-static __inline void exit_(integer *rc)
-{
-    exit(*rc);
-}
-
-integer pow_ii(integer *ap, integer *bp);
-double pow_ri(real *ap, integer *bp);
-double pow_di(doublereal *ap, integer *bp);
-
-static __inline double pow_dd(doublereal *ap, doublereal *bp)
-{
-    return pow(*ap, *bp);
-}
-
-logical slaisnan_(real *in1, real *in2);
-logical dlaisnan_(doublereal *din1, doublereal *din2);
-
-static __inline logical sisnan_(real *in1)
-{
-    return slaisnan_(in1, in1);
-}
-
-static __inline logical disnan_(doublereal *din1)
-{
-    return dlaisnan_(din1, din1);
-}
-
-char *F77_aloc(ftnlen, char*);
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* __BLASWRAP_H */

3rdparty/include/dshow/_mingw_dxhelper.h

@@ -0,0 +1,110 @@
+/**
+ * This file has no copyright assigned and is placed in the Public Domain.
+ * This file is part of the w64 mingw-runtime package.
+ * No warranty is given; refer to the file DISCLAIMER within this package.
+ */
+
+#if defined(_MSC_VER) && !defined(_MSC_EXTENSIONS)
+#define NONAMELESSUNION		1
+#endif
+#if defined(NONAMELESSSTRUCT) && \
+   !defined(NONAMELESSUNION)
+#define NONAMELESSUNION		1
+#endif
+#if defined(NONAMELESSUNION)  && \
+   !defined(NONAMELESSSTRUCT)
+#define NONAMELESSSTRUCT	1
+#endif
+
+#ifndef __ANONYMOUS_DEFINED
+#define __ANONYMOUS_DEFINED
+#if defined(__GNUC__) || defined(__GNUG__)
+#define _ANONYMOUS_UNION	__extension__
+#define _ANONYMOUS_STRUCT	__extension__
+#else
+#define _ANONYMOUS_UNION
+#define _ANONYMOUS_STRUCT
+#endif
+#ifndef NONAMELESSUNION
+#define _UNION_NAME(x)
+#define _STRUCT_NAME(x)
+#else /* NONAMELESSUNION */
+#define _UNION_NAME(x)  x
+#define _STRUCT_NAME(x) x
+#endif
+#endif	/* __ANONYMOUS_DEFINED */
+
+#ifndef DUMMYUNIONNAME
+# ifdef NONAMELESSUNION
+#  define DUMMYUNIONNAME  u
+#  define DUMMYUNIONNAME1 u1	/* Wine uses this variant */
+#  define DUMMYUNIONNAME2 u2
+#  define DUMMYUNIONNAME3 u3
+#  define DUMMYUNIONNAME4 u4
+#  define DUMMYUNIONNAME5 u5
+#  define DUMMYUNIONNAME6 u6
+#  define DUMMYUNIONNAME7 u7
+#  define DUMMYUNIONNAME8 u8
+#  define DUMMYUNIONNAME9 u9
+# else /* NONAMELESSUNION */
+#  define DUMMYUNIONNAME
+#  define DUMMYUNIONNAME1	/* Wine uses this variant */
+#  define DUMMYUNIONNAME2
+#  define DUMMYUNIONNAME3
+#  define DUMMYUNIONNAME4
+#  define DUMMYUNIONNAME5
+#  define DUMMYUNIONNAME6
+#  define DUMMYUNIONNAME7
+#  define DUMMYUNIONNAME8
+#  define DUMMYUNIONNAME9
+# endif
+#endif	/* DUMMYUNIONNAME */
+
+#if !defined(DUMMYUNIONNAME1)	/* MinGW does not define this one */
+# ifdef NONAMELESSUNION
+#  define DUMMYUNIONNAME1 u1	/* Wine uses this variant */
+# else
+#  define DUMMYUNIONNAME1	/* Wine uses this variant */
+# endif
+#endif	/* DUMMYUNIONNAME1 */
+
+#ifndef DUMMYSTRUCTNAME
+# ifdef NONAMELESSUNION
+#  define DUMMYSTRUCTNAME  s
+#  define DUMMYSTRUCTNAME1 s1	/* Wine uses this variant */
+#  define DUMMYSTRUCTNAME2 s2
+#  define DUMMYSTRUCTNAME3 s3
+#  define DUMMYSTRUCTNAME4 s4
+#  define DUMMYSTRUCTNAME5 s5
+# else
+#  define DUMMYSTRUCTNAME
+#  define DUMMYSTRUCTNAME1	/* Wine uses this variant */
+#  define DUMMYSTRUCTNAME2
+#  define DUMMYSTRUCTNAME3
+#  define DUMMYSTRUCTNAME4
+#  define DUMMYSTRUCTNAME5
+# endif
+#endif /* DUMMYSTRUCTNAME */
+
+/* These are for compatibility with the Wine source tree */
+
+#ifndef WINELIB_NAME_AW
+# ifdef __MINGW_NAME_AW
+#   define WINELIB_NAME_AW  __MINGW_NAME_AW
+# else
+#  ifdef UNICODE
+#   define WINELIB_NAME_AW(func) func##W
+#  else
+#   define WINELIB_NAME_AW(func) func##A
+#  endif
+# endif
+#endif	/* WINELIB_NAME_AW */
+
+#ifndef DECL_WINELIB_TYPE_AW
+# ifdef __MINGW_TYPEDEF_AW
+#  define DECL_WINELIB_TYPE_AW  __MINGW_TYPEDEF_AW
+# else
+#  define DECL_WINELIB_TYPE_AW(type)  typedef WINELIB_NAME_AW(type) type;
+# endif
+#endif	/* DECL_WINELIB_TYPE_AW */
+

3rdparty/include/dshow/_mingw_unicode.h

@@ -0,0 +1,33 @@
+/**
+ * This file has no copyright assigned and is placed in the Public Domain.
+ * This file is part of the w64 mingw-runtime package.
+ * No warranty is given; refer to the file DISCLAIMER.PD within this package.
+ */
+
+#if !defined(_INC_CRT_UNICODE_MACROS)
+/* _INC_CRT_UNICODE_MACROS defined based on UNICODE flag */
+
+#if defined(UNICODE)
+# define _INC_CRT_UNICODE_MACROS 1
+# define __MINGW_NAME_AW(func) func##W
+# define __MINGW_NAME_AW_EXT(func,ext) func##W##ext
+# define __MINGW_NAME_UAW(func) func##_W
+# define __MINGW_NAME_UAW_EXT(func,ext) func##_W_##ext
+# define __MINGW_STRING_AW(str) L##str	/* same as TEXT() from winnt.h */
+# define __MINGW_PROCNAMEEXT_AW "W"
+#else
+# define _INC_CRT_UNICODE_MACROS 2
+# define __MINGW_NAME_AW(func) func##A
+# define __MINGW_NAME_AW_EXT(func,ext) func##A##ext
+# define __MINGW_NAME_UAW(func) func##_A
+# define __MINGW_NAME_UAW_EXT(func,ext) func##_A_##ext
+# define __MINGW_STRING_AW(str) str	/* same as TEXT() from winnt.h */
+# define __MINGW_PROCNAMEEXT_AW "A"
+#endif
+
+#define __MINGW_TYPEDEF_AW(type)	\
+    typedef __MINGW_NAME_AW(type) type;
+#define __MINGW_TYPEDEF_UAW(type)	\
+    typedef __MINGW_NAME_UAW(type) type;
+
+#endif /* !defined(_INC_CRT_UNICODE_MACROS) */

3rdparty/include/dshow/audevcod.h

@@ -0,0 +1,31 @@
+#ifndef _AUDEVCOD_H
+#define _AUDEVCOD_H
+#if __GNUC__ >=3
+#pragma GCC system_header
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+typedef enum _tagSND_DEVICE_ERROR {
+	SNDDEV_ERROR_Open = 1,       
+	SNDDEV_ERROR_Close = 2,       
+	SNDDEV_ERROR_GetCaps = 3,       
+	SNDDEV_ERROR_PrepareHeader = 4,
+	SNDDEV_ERROR_UnprepareHeader = 5,       
+	SNDDEV_ERROR_Reset = 6,
+	SNDDEV_ERROR_Restart = 7,       
+	SNDDEV_ERROR_GetPosition = 8,       
+	SNDDEV_ERROR_Write = 9,
+	SNDDEV_ERROR_Pause = 10,       
+	SNDDEV_ERROR_Stop = 11,       
+	SNDDEV_ERROR_Start = 12,       
+	SNDDEV_ERROR_AddBuffer = 13,
+	SNDDEV_ERROR_Query = 14
+} SNDDEV_ERR;
+
+#ifdef __cplusplus
+}
+#endif
+#endif

3rdparty/include/dshow/bdatypes.h

@@ -0,0 +1,32 @@
+#ifndef _BDATYPES_H
+#define _BDATYPES_H
+#if __GNUC__ >= 3
+#pragma GCC system_header
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*--- DirectShow Reference - DirectShow Enumerated Types */
+typedef enum {
+	MEDIA_TRANSPORT_PACKET,
+	MEDIA_ELEMENTARY_STREAM,
+	MEDIA_MPEG2_PSI,
+	MEDIA_TRANSPORT_PAYLOAD
+} MEDIA_SAMPLE_CONTENT;
+/*--- DirectShow Reference - DirectShow Structures */
+typedef struct {
+	DWORD dwOffset;
+	DWORD dwPacketLength;
+	DWORD dwStride;
+} MPEG2_TRANSPORT_STRIDE;
+typedef struct {
+	ULONG ulPID;
+	MEDIA_SAMPLE_CONTENT MediaSampleContent ;
+} PID_MAP;
+
+#ifdef __cplusplus
+}
+#endif
+#endif

3rdparty/include/dshow/dshow.h

@@ -0,0 +1,61 @@
+/*
+ * Copyright (C) 2002 Alexandre Julliard
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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 for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
+ */
+
+#ifndef __DSHOW_INCLUDED__
+#define __DSHOW_INCLUDED__
+
+#define AM_NOVTABLE
+
+#ifndef __WINESRC__
+# include <windows.h>
+# include <windowsx.h>
+#else
+# include <windef.h>
+# include <wingdi.h>
+# include <objbase.h>
+#endif
+#include <olectl.h>
+#include <dshow/ddraw.h>
+#include <mmsystem.h>
+/* FIXME: #include <strsafe.h>*/
+
+#ifndef NUMELMS
+#define NUMELMS(array) (sizeof(array)/sizeof((array)[0]))
+#endif
+
+#include <dshow/strmif.h>
+#include <dshow/amvideo.h>
+#ifdef DSHOW_USE_AMAUDIO
+/* FIXME: #include <amaudio.h>*/
+#endif
+#include <dshow/control.h>
+#include <dshow/evcode.h>
+#include <dshow/uuids.h>
+#include <dshow/errors.h>
+/* FIXME: #include <edevdefs.h> */
+#include <dshow/audevcod.h>
+/* FIXME: #include <dvdevcod.h> */
+
+#ifndef OATRUE
+#define OATRUE (-1)
+#endif
+#ifndef OAFALSE
+#define OAFALSE (0)
+#endif
+
+#endif /* __DSHOW_INCLUDED__ */

3rdparty/include/dshow/dvdmedia.h

@@ -0,0 +1,75 @@
+/*
+ * Copyright (C) 2008 Maarten Lankhorst
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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 for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
+ */
+
+#ifndef __DVDMEDIA_H__
+#define __DVDMEDIA_H__
+
+#define AMCONTROL_USED 0x00000001
+#define AMCONTROL_PAD_TO_4x3 0x00000002
+#define AMCONTROL_PAD_TO_16x9 0x00000004
+
+enum AM_MPEG2Level {
+	AM_MPEG2Level_Low = 1,
+	AM_MPEG2Level_Main,
+	AM_MPEG2Level_High1440,
+	AM_MPEG2Level_High
+};
+enum AM_MPEG2Profile {
+	AM_MPEG2Profile_Simple = 1,
+	AM_MPEG2Profile_Main,
+	AM_MPEG2Profile_SNRScalable,
+	AM_MPEG2Profile_SpatiallyScalable,
+	AM_MPEG2Profile_High
+};
+typedef enum {
+	AM_RATE_ChangeRate = 1,
+	AM_RATE_FullDataRateMax = 2,
+	AM_RATE_ReverseDecode = 3,
+	AM_RATE_DecoderPosition = 4,
+	AM_RATE_DecoderVersion = 5
+} AM_PROPERTY_DVD_RATE_CHANGE;
+
+typedef struct tagVIDEOINFOHEADER2 {
+    RECT rcSource;
+    RECT rcTarget;
+    DWORD dwBitRate;
+    DWORD dwBitErrorRate;
+    REFERENCE_TIME AvgTimePerFrame;
+    DWORD dwInterlaceFlags;
+    DWORD dwCopyProtectFlags;
+    DWORD dwPictAspectRatioX;
+    DWORD dwPictAspectRatioY;
+    union {
+        DWORD dwControlFlags;
+        DWORD dwReserved1;
+    } DUMMYUNIONNAME;
+    DWORD dwReserved2;
+    BITMAPINFOHEADER bmiHeader;
+} VIDEOINFOHEADER2;
+
+typedef struct tagMPEG2VIDEOINFO {
+    VIDEOINFOHEADER2 hdr;
+    DWORD dwStartTimeCode;
+    DWORD cbSequenceHeader;
+    DWORD dwProfile;
+    DWORD dwLevel;
+    DWORD dwFlags;
+    DWORD dwSequenceHeader[1];
+} MPEG2VIDEOINFO;
+
+#endif /* __DVDMEDIA_H__ */

3rdparty/include/dshow/errors.h

@@ -0,0 +1,169 @@
+#ifndef _ERRORS_H
+#define _ERRORS_H
+#if __GNUC__ >=3
+#pragma GCC system_header
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*--- DirectShow Reference - Constants and GUIDs - Error and Success Codes */
+#define VFW_S_NO_MORE_ITEMS 0x00040103
+#define VFW_S_DUPLICATE_NAME 0x0004022D
+#define VFW_S_STATE_INTERMEDIATE 0x00040237
+#define VFW_S_PARTIAL_RENDER 0x00040242
+#define VFW_S_SOME_DATA_IGNORED 0x00040245
+#define VFW_S_CONNECTIONS_DEFERRED 0x00040246
+#define VFW_S_RESOURCE_NOT_NEEDED 0x00040250
+#define VFW_S_MEDIA_TYPE_IGNORED 0x00040254
+#define VFW_S_VIDEO_NOT_RENDERED 0x00040257
+#define VFW_S_AUDIO_NOT_RENDERED 0x00040258
+#define VFW_S_RPZA 0x0004025A
+#define VFW_S_ESTIMATED 0x00040260
+#define VFW_S_RESERVED 0x00040263
+#define VFW_S_STREAM_OFF 0x00040267
+#define VFW_S_CANT_CUE 0x00040268
+#define VFW_S_NOPREVIEWPIN 0x0004027E
+#define VFW_S_DVD_NON_ONE_SEQUENTIAL 0x00040280
+#define VFW_S_DVD_CHANNEL_CONTENTS_NOT_AVAILABLE 0x0004028C
+#define VFW_S_DVD_NOT_ACCURATE 0x0004028D
+#define VFW_E_INVALIDMEDIATYPE 0x80040200
+#define VFW_E_INVALIDSUBTYPE 0x80040201
+#define VFW_E_NEED_OWNER 0x80040202
+#define VFW_E_ENUM_OUT_OF_SYNC 0x80040203
+#define VFW_E_ALREADY_CONNECTED 0x80040204
+#define VFW_E_FILTER_ACTIVE 0x80040205
+#define VFW_E_NO_TYPES 0x80040206
+#define VFW_E_NO_ACCEPTABLE_TYPES 0x80040207
+#define VFW_E_INVALID_DIRECTION 0x80040208
+#define VFW_E_NOT_CONNECTED 0x80040209
+#define VFW_E_NO_ALLOCATOR 0x8004020A
+#define VFW_E_RUNTIME_ERROR 0x8004020B
+#define VFW_E_BUFFER_NOTSET 0x8004020C
+#define VFW_E_BUFFER_OVERFLOW 0x8004020D
+#define VFW_E_BADALIGN 0x8004020E
+#define VFW_E_ALREADY_COMMITTED 0x8004020F
+#define VFW_E_BUFFERS_OUTSTANDING 0x80040210
+#define VFW_E_NOT_COMMITTED 0x80040211
+#define VFW_E_SIZENOTSET 0x80040212
+#define VFW_E_NO_CLOCK 0x80040213
+#define VFW_E_NO_SINK 0x80040214
+#define VFW_E_NO_INTERFACE 0x80040215
+#define VFW_E_NOT_FOUND 0x80040216
+#define VFW_E_CANNOT_CONNECT 0x80040217
+#define VFW_E_CANNOT_RENDER 0x80040218
+#define VFW_E_CHANGING_FORMAT 0x80040219
+#define VFW_E_NO_COLOR_KEY_SET 0x8004021A
+#define VFW_E_NOT_OVERLAY_CONNECTION 0x8004021B
+#define VFW_E_NOT_SAMPLE_CONNECTION 0x8004021C
+#define VFW_E_PALETTE_SET 0x8004021D
+#define VFW_E_COLOR_KEY_SET 0x8004021E
+#define VFW_E_NO_COLOR_KEY_FOUND 0x8004021F
+#define VFW_E_NO_PALETTE_AVAILABLE 0x80040220
+#define VFW_E_NO_DISPLAY_PALETTE 0x80040221
+#define VFW_E_TOO_MANY_COLORS 0x80040222
+#define VFW_E_STATE_CHANGED 0x80040223
+#define VFW_E_NOT_STOPPED 0x80040224
+#define VFW_E_NOT_PAUSED 0x80040225
+#define VFW_E_NOT_RUNNING 0x80040226
+#define VFW_E_WRONG_STATE 0x80040227
+#define VFW_E_START_TIME_AFTER_END 0x80040228
+#define VFW_E_INVALID_RECT 0x80040229
+#define VFW_E_TYPE_NOT_ACCEPTED 0x8004022A
+#define VFW_E_SAMPLE_REJECTED 0x8004022B
+#define VFW_E_SAMPLE_REJECTED_EOS 0x8004022C
+#define VFW_E_DUPLICATE_NAME 0x8004022D
+#define VFW_E_TIMEOUT 0x8004022E
+#define VFW_E_INVALID_FILE_FORMAT 0x8004022F
+#define VFW_E_ENUM_OUT_OF_RANGE 0x80040230
+#define VFW_E_CIRCULAR_GRAPH 0x80040231
+#define VFW_E_NOT_ALLOWED_TO_SAVE 0x80040232
+#define VFW_E_TIME_ALREADY_PASSED 0x80040233
+#define VFW_E_ALREADY_CANCELLED 0x80040234
+#define VFW_E_CORRUPT_GRAPH_FILE 0x80040235
+#define VFW_E_ADVISE_ALREADY_SET 0x80040236
+#define VFW_E_NO_MODEX_AVAILABLE 0x80040238
+#define VFW_E_NO_ADVISE_SET 0x80040239
+#define VFW_E_NO_FULLSCREEN 0x8004023A
+#define VFW_E_IN_FULLSCREEN_MODE 0x8004023B
+#define VFW_E_UNKNOWN_FILE_TYPE 0x80040240
+#define VFW_E_CANNOT_LOAD_SOURCE_FILTER 0x80040241
+#define VFW_E_FILE_TOO_SHORT 0x80040243
+#define VFW_E_INVALID_FILE_VERSION 0x80040244
+#define VFW_E_INVALID_CLSID 0x80040247
+#define VFW_E_INVALID_MEDIA_TYPE 0x80040248
+#define VFW_E_SAMPLE_TIME_NOT_SET 0x80040249
+#define VFW_E_MEDIA_TIME_NOT_SET 0x80040251
+#define VFW_E_NO_TIME_FORMAT_SET 0x80040252
+#define VFW_E_MONO_AUDIO_HW 0x80040253
+#define VFW_E_NO_DECOMPRESSOR 0x80040255
+#define VFW_E_NO_AUDIO_HARDWARE 0x80040256
+#define VFW_E_RPZA 0x80040259
+#define VFW_E_PROCESSOR_NOT_SUITABLE 0x8004025B
+#define VFW_E_UNSUPPORTED_AUDIO 0x8004025C
+#define VFW_E_UNSUPPORTED_VIDEO 0x8004025D
+#define VFW_E_MPEG_NOT_CONSTRAINED 0x8004025E
+#define VFW_E_NOT_IN_GRAPH 0x8004025F
+#define VFW_E_NO_TIME_FORMAT 0x80040261
+#define VFW_E_READ_ONLY 0x80040262
+#define VFW_E_BUFFER_UNDERFLOW 0x80040264
+#define VFW_E_UNSUPPORTED_STREAM 0x80040265
+#define VFW_E_NO_TRANSPORT 0x80040266
+#define VFW_E_BAD_VIDEOCD 0x80040269
+#define VFW_S_NO_STOP_TIME 0x80040270
+#define VFW_E_OUT_OF_VIDEO_MEMORY 0x80040271
+#define VFW_E_VP_NEGOTIATION_FAILED 0x80040272
+#define VFW_E_DDRAW_CAPS_NOT_SUITABLE 0x80040273
+#define VFW_E_NO_VP_HARDWARE 0x80040274
+#define VFW_E_NO_CAPTURE_HARDWARE 0x80040275
+#define VFW_E_DVD_OPERATION_INHIBITED 0x80040276
+#define VFW_E_DVD_INVALIDDOMAIN 0x80040277
+#define VFW_E_DVD_NO_BUTTON 0x80040278
+#define VFW_E_DVD_GRAPHNOTREADY 0x80040279
+#define VFW_E_DVD_RENDERFAIL 0x8004027A
+#define VFW_E_DVD_DECNOTENOUGH 0x8004027B
+#define VFW_E_DDRAW_VERSION_NOT_SUITABLE 0x8004027C
+#define VFW_E_COPYPROT_FAILED 0x8004027D
+#define VFW_E_TIME_EXPIRED 0x8004027F
+#define VFW_E_DVD_WRONG_SPEED 0x80040281
+#define VFW_E_DVD_MENU_DOES_NOT_EXIST 0x80040282
+#define VFW_E_DVD_CMD_CANCELLED 0x80040283
+#define VFW_E_DVD_STATE_WRONG_VERSION 0x80040284
+#define VFW_E_DVD_STATE_CORRUPT 0x80040285
+#define VFW_E_DVD_STATE_WRONG_DISC 0x80040286
+#define VFW_E_DVD_INCOMPATIBLE_REGION 0x80040287
+#define VFW_E_DVD_NO_ATTRIBUTES 0x80040288
+#define VFW_E_DVD_NO_GOUP_PGC 0x80040289
+#define VFW_E_DVD_LOW_PARENTAL_LEVEL 0x8004028A
+#define VFW_E_DVD_NOT_IN_KARAOKE_MODE 0x8004028B
+#define VFW_E_FRAME_STEP_UNSUPPORTED 0x8004028E
+#define VFW_E_DVD_STREAM_DISABLED 0x8004028F
+#define VFW_E_DVD_TITLE_UNKNOWN 0x80040290
+#define VFW_E_DVD_INVALID_DISC 0x80040291
+#define VFW_E_DVD_NO_RESUME_INFORMATION 0x80040292
+#define VFW_E_PIN_ALREADY_BLOCKED_ON_THIS_THREAD 0x80040293
+#define VFW_E_PIN_ALREADY_BLOCKED 0x80040294
+#define VFW_E_CERTIFICATION_FAILURE 0x80040295
+#define VFW_E_VMR_NOT_IN_MIXER_MODE 0x80040296
+#define VFW_E_VMR_NO_AP_SUPPLIED 0x80040297
+#define VFW_E_VMR_NO_DEINTERLACE_HW 0x80040298
+#define VFW_E_VMR_NO_PROCAMP_HW 0x80040299
+#define VFW_E_DVD_VMR9_INCOMPATIBLEDEC 0x8004029A
+#define VFW_E_NO_COPP_HW 0x8004029B
+#define VFW_E_BAD_KEY 0x800403F2
+/*--- DirectShow Reference - Functions */
+#define MAX_ERROR_TEXT_LEN 160
+/*--- DirectShow Reference - Functions */
+DWORD WINAPI AMGetErrorTextA(HRESULT,CHAR*,DWORD);
+DWORD WINAPI AMGetErrorTextW(HRESULT,WCHAR*,DWORD);
+#ifdef UNICODE
+#define AMGetErrorText AMGetErrorTextW
+#else
+#define AMGetErrorText AMGetErrorTextA
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+#endif

3rdparty/include/dshow/evcode.h

@@ -0,0 +1,68 @@
+#ifndef _EVCODE_H
+#define _EVCODE_H
+#if __GNUC__ >=3
+#pragma GCC system_header
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*--- DirectShow Reference - Constants and GUIDs - Event Notification Codes */
+#define EC_ACTIVATE 0x0013
+#define EC_BUFFERING_DATA 0x0011
+#define EC_BUILT 0x0300
+#define EC_CLOCK_CHANGED 0x000D
+#define EC_CLOCK_UNSET 0x0051
+#define EC_CODECAPI_EVENT 0x0057
+#define EC_COMPLETE 0x0001
+#define EC_DEVICE_LOST 0x001F
+#define EC_DISPLAY_CHANGED 0x0016
+#define EC_END_OF_SEGMENT 0x001C
+#define EC_ERROR_STILLPLAYING 0x0008
+#define EC_ERRORABORT 0x0003
+#define EC_EXTDEVICE_MODE_CHANGE 0x0031
+#define EC_FULLSCREEN_LOST 0x0012
+#define EC_GRAPH_CHANGED 0x0050
+#define EC_LENGTH_CHANGED 0x001E
+#define EC_NEED_RESTART 0x0014
+#define EC_NOTIFY_WINDOW 0x0019
+#define EC_OLE_EVENT 0x0018
+#define EC_OPENING_FILE 0x0010
+#define EC_PALETTE_CHANGED 0x0009
+#define EC_PAUSED 0x000E
+#define EC_PREPROCESS_COMPLETE 0x0056
+#define EC_QUALITY_CHANGE 0x000B
+#define EC_REPAINT 0x0005
+#define EC_SEGMENT_STARTED 0x001D
+#define EC_SHUTTING_DOWN 0x000C
+#define EC_SNDDEV_IN_ERROR 0x0200
+#define EC_SNDDEV_OUT_ERROR 0x0201
+#define EC_STARVATION 0x0017
+#define EC_STATE_CHANGE 0x0032
+#define EC_STEP_COMPLETE 0x0024
+#define EC_STREAM_CONTROL_STARTED 0x001B
+#define EC_STREAM_CONTROL_STOPPED 0x001A
+#define EC_STREAM_ERROR_STILLPLAYING 0x0007
+#define EC_STREAM_ERROR_STOPPED 0x0006
+#define EC_TIMECODE_AVAILABLE 0x0030
+#define EC_UNBUILT 0x0301
+#define EC_USERABORT 0x0002
+#define EC_VIDEO_SIZE_CHANGED 0x000A
+#define EC_VMR_RENDERDEVICE_SET 0x0053
+#define EC_VMR_SURFACE_FLIPPED 0x0054
+#define EC_VMR_RECONNECTION_FAILED 0x0055
+#define EC_WINDOW_DESTROYED 0x0015
+#define EC_WMT_EVENT 0x0252
+#define EC_WMT_INDEX_EVENT 0x0251
+#define EC_USER 0x8000
+/*--- DirectShow Reference - DirectShow Structures */
+typedef struct {
+	HRESULT hrStatus;
+	void   *pData;
+} AM_WMT_EVENT_DATA;
+
+#ifdef __cplusplus
+}
+#endif
+#endif

3rdparty/include/dshow/ksuuids.h

@@ -0,0 +1,191 @@
+/**
+ * This file has no copyright assigned and is placed in the Public Domain.
+ * This file is part of the w64 mingw-runtime package.
+ * No warranty is given; refer to the file DISCLAIMER.PD within this package.
+ */
+
+OUR_GUID_ENTRY(MEDIATYPE_MPEG2_PACK,
+		0x36523B13,0x8EE5,0x11d1,0x8C,0xA3,0x00,0x60,0xB0,0x57,0x66,0x4A)
+
+OUR_GUID_ENTRY(MEDIATYPE_MPEG2_PES,
+		0xe06d8020,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x5f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_WMDRM_TRANSPORT,
+		0x18BEC4EA,0x4676,0x450e,0xB4,0x78,0x0C,0xD8,0x4C,0x54,0xB3,0x27)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_VIDEO,
+		0xe06d8026,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x5f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(FORMAT_MPEG2_VIDEO,
+		0xe06d80e3,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x5f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(FORMAT_VIDEOINFO2,
+		0xf72a76A0L,0xeb0a,0x11d0,0xac,0xe4,0x0,0x0,0xc0,0xcc,0x16,0xba)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_PROGRAM,
+		0xe06d8022,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_TRANSPORT,
+		0xe06d8023,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_AUDIO,
+		0xe06d802b,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_DOLBY_AC3,
+		0xe06d802c,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_DVD_SUBPICTURE,
+		0xe06d802d,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_DVD_LPCM_AUDIO,
+		0xe06d8032,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIATYPE_DVD_ENCRYPTED_PACK,
+		0xed0b916a,0x044d,0x11d1,0xaa,0x78,0x00,0xc0,0x04f,0xc3,0x1d,0x60)
+
+OUR_GUID_ENTRY(MEDIATYPE_DVD_NAVIGATION,
+		0xe06d802e,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_DVD_NAVIGATION_PCI,
+		0xe06d802f,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_DVD_NAVIGATION_DSI,
+		0xe06d8030,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_DVD_NAVIGATION_PROVIDER,
+		0xe06d8031,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(FORMAT_MPEG2Video,
+		0xe06d80e3,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(FORMAT_DolbyAC3,
+		0xe06d80e4,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(FORMAT_MPEG2Audio,
+		0xe06d80e5,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(FORMAT_DVD_LPCMAudio,
+		0xe06d80e6,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(AM_KSPROPSETID_AC3,
+		0xBFABE720,0x6E1F,0x11D0,0xBC,0xF2,0x44,0x45,0x53,0x54,0x00,0x00)
+
+OUR_GUID_ENTRY(AM_KSPROPSETID_DvdSubPic,
+		0xac390460,0x43af,0x11d0,0xbd,0x6a,0x00,0x35,0x05,0xc1,0x03,0xa9)
+
+OUR_GUID_ENTRY(AM_KSPROPSETID_CopyProt,
+		0x0E8A0A40,0x6AEF,0x11D0,0x9E,0xD0,0x00,0xA0,0x24,0xCA,0x19,0xB3)
+
+OUR_GUID_ENTRY(AM_KSPROPSETID_TSRateChange,
+		0xa503c5c0,0x1d1d,0x11d1,0xad,0x80,0x44,0x45,0x53,0x54,0x0,0x0)
+
+OUR_GUID_ENTRY(AM_KSPROPSETID_MPEG4_MediaType_Attributes,
+		0xff6c4bfa,0x7a9,0x4c7b,0xa2,0x37,0x67,0x2f,0x9d,0x68,0x6,0x5f)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_CAPTURE,
+		0x65E8773DL,0x8F56,0x11D0,0xA3,0xB9,0x00,0xA0,0xC9,0x22,0x31,0x96)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_RENDER,
+		0x65E8773EL,0x8F56,0x11D0,0xA3,0xB9,0x00,0xA0,0xC9,0x22,0x31,0x96)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_DATACOMPRESSOR,
+		0x1E84C900L,0x7E70,0x11D0,0xA5,0xD6,0x28,0xDB,0x04,0xC1,0x00,0x00)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_AUDIO,
+		0x6994AD04L,0x93EF,0x11D0,0xA3,0xCC,0x00,0xA0,0xC9,0x22,0x31,0x96)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_VIDEO,
+		0x6994AD05L,0x93EF,0x11D0,0xA3,0xCC,0x00,0xA0,0xC9,0x22,0x31,0x96)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_TVTUNER,
+		0xa799a800L,0xa46d,0x11d0,0xa1,0x8c,0x00,0xa0,0x24,0x01,0xdc,0xd4)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_CROSSBAR,
+		0xa799a801L,0xa46d,0x11d0,0xa1,0x8c,0x00,0xa0,0x24,0x01,0xdc,0xd4)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_TVAUDIO,
+		0xa799a802L,0xa46d,0x11d0,0xa1,0x8c,0x00,0xa0,0x24,0x01,0xdc,0xd4)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_VBICODEC,
+		0x07dad660L,0x22f1,0x11d1,0xa9,0xf4,0x00,0xc0,0x4f,0xbb,0xde,0x8f)
+
+OUR_GUID_ENTRY(AM_KSCATEGORY_SPLITTER,
+		0x0A4252A0L,0x7E70,0x11D0,0xA5,0xD6,0x28,0xDB,0x04,0xC1,0x00,0x00)
+
+OUR_GUID_ENTRY(IID_IKsInterfaceHandler,
+		0xD3ABC7E0L,0x9A61,0x11D0,0xA4,0x0D,0x00,0xA0,0xC9,0x22,0x31,0x96)
+
+OUR_GUID_ENTRY(IID_IKsDataTypeHandler,
+		0x5FFBAA02L,0x49A3,0x11D0,0x9F,0x36,0x00,0xAA,0x00,0xA2,0x16,0xA1)
+
+OUR_GUID_ENTRY(IID_IKsPin,
+		0xb61178d1L,0xa2d9,0x11cf,0x9e,0x53,0x00,0xaa,0x00,0xa2,0x16,0xa1)
+
+OUR_GUID_ENTRY(IID_IKsControl,
+		0x28F54685L,0x06FD,0x11D2,0xB2,0x7A,0x00,0xA0,0xC9,0x22,0x31,0x96)
+
+OUR_GUID_ENTRY(IID_IKsPinFactory,
+		0xCD5EBE6BL,0x8B6E,0x11D1,0x8A,0xE0,0x00,0xA0,0xC9,0x22,0x31,0x96)
+
+OUR_GUID_ENTRY(AM_INTERFACESETID_Standard,
+		0x1A8766A0L,0x62CE,0x11CF,0xA5,0xD6,0x28,0xDB,0x04,0xC1,0x00,0x00)
+
+#if ( (NTDDI_VERSION >= NTDDI_WINXPSP2) && (NTDDI_VERSION < NTDDI_WS03) ) || (NTDDI_VERSION >= NTDDI_WS03SP1)
+OUR_GUID_ENTRY(MEDIATYPE_MPEG2_SECTIONS,
+		0x455f176c,0x4b06,0x47ce,0x9a,0xef,0x8c,0xae,0xf7,0x3d,0xf7,0xb5)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_VERSIONED_TABLES,
+		0x1ed988b0,0x3ffc,0x4523,0x87,0x25,0x34,0x7b,0xee,0xc1,0xa8,0xa0)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_ATSC_SI,
+		0xb3c7397c,0xd303,0x414d,0xb3,0x3c,0x4e,0xd2,0xc9,0xd2,0x97,0x33)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_DVB_SI,
+		0xe9dd31a3,0x221d,0x4adb,0x85,0x32,0x9a,0xf3,0x9,0xc1,0xa4,0x8)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_ISDB_SI,
+		0xe89ad298,0x3601,0x4b06,0xaa,0xec,0x9d,0xde,0xed,0xcc,0x5b,0xd0)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_TIF_SI,
+		0xec232eb2,0xcb96,0x4191,0xb2,0x26,0xe,0xa1,0x29,0xf3,0x82,0x50)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2DATA,
+		0xc892e55b,0x252d,0x42b5,0xa3,0x16,0xd9,0x97,0xe7,0xa5,0xd9,0x95)
+#endif
+/* ( (NTDDI_VERSION >= NTDDI_WINXPSP2) && (NTDDI_VERSION < NTDDI_WS03) ) ||
+						(NTDDI_VERSION >= NTDDI_WS03SP1) */
+
+#if (NTDDI_VERSION >= NTDDI_WINXP)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_TRANSPORT_STRIDE,
+		0x138aa9a4,0x1ee2,0x4c5b,0x98,0x8e,0x19,0xab,0xfd,0xbc,0x8a,0x11)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_UDCR_TRANSPORT,
+		0x18BEC4EA,0x4676,0x450e,0xB4,0x78,0x0C,0xD8,0x4C,0x54,0xB3,0x27)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_PBDA_TRANSPORT_RAW,
+		0x0d7aed42,0xcb9a,0x11db,0x97,0x5,0x0,0x50,0x56,0xc0,0x0,0x8)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG2_PBDA_TRANSPORT_PROCESSED,
+		0xaf748dd4,0xd80,0x11db,0x97,0x5,0x0,0x50,0x56,0xc0,0x0,0x8)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_DTS,
+		0xe06d8033,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_SDDS,
+		0xe06d8034,0xdb46,0x11cf,0xb4,0xd1,0x00,0x80,0x05f,0x6c,0xbb,0xea)
+
+OUR_GUID_ENTRY(AM_KSPROPSETID_DVD_RateChange,
+		0x3577eb09,0x9582,0x477f,0xb2,0x9c,0xb0,0xc4,0x52,0xa4,0xff,0x9a)
+
+OUR_GUID_ENTRY(AM_KSPROPSETID_DvdKaraoke,
+		0xae4720ae,0xaa71,0x42d8,0xb8,0x2a,0xff,0xfd,0xf5,0x8b,0x76,0xfd)
+
+OUR_GUID_ENTRY(AM_KSPROPSETID_FrameStep,
+		0xc830acbd,0xab07,0x492f,0x88,0x52,0x45,0xb6,0x98,0x7c,0x29,0x79)
+#endif /* NTDDI_VERSION >= NTDDI_WINXP */
+
+#if (NTDDI_VERSION >= NTDDI_WS03SP1)
+OUR_GUID_ENTRY(AM_KSCATEGORY_VBICODEC_MI,
+		0x9c24a977,0x951,0x451a,0x80,0x6,0xe,0x49,0xbd,0x28,0xcd,0x5f)
+#endif /* NTDDI_VERSION >= NTDDI_WS03SP1 */
+

3rdparty/include/dshow/uuids.h

@@ -0,0 +1,368 @@
+/**
+ * This file has no copyright assigned and is placed in the Public Domain.
+ * This file is part of the w64 mingw-runtime package.
+ * No warranty is given; refer to the file DISCLAIMER.PD within this package.
+ */
+#ifndef OUR_GUID_ENTRY
+#define OUR_GUID_ENTRY(name,l,w1,w2,b1,b2,b3,b4,b5,b6,b7,b8) DEFINE_GUID(name,l,w1,w2,b1,b2,b3,b4,b5,b6,b7,b8);
+#endif
+
+#define MEDIATYPE_NULL GUID_NULL
+#define MEDIASUBTYPE_NULL GUID_NULL
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_None,0xe436eb8e,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIATYPE_Video,0x73646976,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_Audio,0x73647561,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_Text,0x73747874,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_Midi,0x7364696D,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_Stream,0xe436eb83,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIATYPE_Interleaved,0x73766169,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_File,0x656c6966,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_ScriptCommand,0x73636d64,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_AUXLine21Data,0x670aea80,0x3a82,0x11d0,0xb7,0x9b,0x0,0xaa,0x0,0x37,0x67,0xa7)
+OUR_GUID_ENTRY(MEDIATYPE_VBI,0xf72a76e1,0xeb0a,0x11d0,0xac,0xe4,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(MEDIATYPE_Timecode,0x482dee3,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIATYPE_LMRT,0x74726c6d,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_URL_STREAM,0x736c7275,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_CLPL,0x4C504C43,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_YUYV,0x56595559,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IYUV,0x56555949,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_YVU9,0x39555659,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Y411,0x31313459,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Y41P,0x50313459,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_YUY2,0x32595559,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_YVYU,0x55595659,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_UYVY,0x59565955,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Y211,0x31313259,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_CLJR,0x524a4c43,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IF09,0x39304649,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_CPLA,0x414c5043,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MJPG,0x47504A4D,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_TVMJ,0x4A4D5654,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_WAKE,0x454B4157,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_CFCC,0x43434643,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IJPG,0x47504A49,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Plum,0x6D756C50,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_DVCS,0x53435644,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_DVSD,0x44535644,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MDVF,0x4656444D,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB1,0xe436eb78,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB4,0xe436eb79,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB8,0xe436eb7a,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB565,0xe436eb7b,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB555,0xe436eb7c,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB24,0xe436eb7d,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB32,0xe436eb7e,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB1555,0x297c55af,0xe209,0x4cb3,0xb7,0x57,0xc7,0x6d,0x6b,0x9c,0x88,0xa8)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB4444,0x6e6415e6,0x5c24,0x425f,0x93,0xcd,0x80,0x10,0x2b,0x3d,0x1c,0xca)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB32,0x773c9ac0,0x3274,0x11d0,0xb7,0x24,0x0,0xaa,0x0,0x6c,0x1a,0x1)
+OUR_GUID_ENTRY(MEDIASUBTYPE_A2R10G10B10,0x2f8bb76d,0xb644,0x4550,0xac,0xf3,0xd3,0x0c,0xaa,0x65,0xd5,0xc5)
+OUR_GUID_ENTRY(MEDIASUBTYPE_A2B10G10R10,0x576f7893,0xbdf6,0x48c4,0x87,0x5f,0xae,0x7b,0x81,0x83,0x45,0x67)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AYUV,0x56555941,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AI44,0x34344941,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IA44,0x34344149,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB32_D3D_DX7_RT,0x32335237,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB16_D3D_DX7_RT,0x36315237,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB32_D3D_DX7_RT,0x38384137,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB4444_D3D_DX7_RT,0x34344137,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB1555_D3D_DX7_RT,0x35314137,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB32_D3D_DX9_RT,0x32335239,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RGB16_D3D_DX9_RT,0x36315239,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB32_D3D_DX9_RT,0x38384139,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB4444_D3D_DX9_RT,0x34344139,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_ARGB1555_D3D_DX9_RT,0x35314139,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+
+#define MEDIASUBTYPE_HASALPHA(mt) (((mt).subtype==MEDIASUBTYPE_ARGB4444) || ((mt).subtype==MEDIASUBTYPE_ARGB32) || ((mt).subtype==MEDIASUBTYPE_AYUV) || ((mt).subtype==MEDIASUBTYPE_AI44) || ((mt).subtype==MEDIASUBTYPE_IA44) || ((mt).subtype==MEDIASUBTYPE_ARGB1555) || ((mt).subtype==MEDIASUBTYPE_ARGB32_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB4444_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB1555_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB32_D3D_DX9_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB4444_D3D_DX9_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB1555_D3D_DX9_RT))
+#define MEDIASUBTYPE_HASALPHA7(mt) (((mt).subtype==MEDIASUBTYPE_ARGB32_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB4444_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB1555_D3D_DX7_RT))
+#define MEDIASUBTYPE_D3D_DX7_RT(mt) (((mt).subtype==MEDIASUBTYPE_ARGB32_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB4444_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB1555_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_RGB32_D3D_DX7_RT) || ((mt).subtype==MEDIASUBTYPE_RGB16_D3D_DX7_RT))
+#define MEDIASUBTYPE_HASALPHA9(mt) (((mt).subtype==MEDIASUBTYPE_ARGB32_D3D_DX9_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB4444_D3D_DX9_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB1555_D3D_DX9_RT))
+#define MEDIASUBTYPE_D3D_DX9_RT(mt) (((mt).subtype==MEDIASUBTYPE_ARGB32_D3D_DX9_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB4444_D3D_DX9_RT) || ((mt).subtype==MEDIASUBTYPE_ARGB1555_D3D_DX9_RT) || ((mt).subtype==MEDIASUBTYPE_RGB32_D3D_DX9_RT) || ((mt).subtype==MEDIASUBTYPE_RGB16_D3D_DX9_RT))
+
+OUR_GUID_ENTRY(MEDIASUBTYPE_YV12,0x32315659,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_NV12,0x3231564E,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IMC1,0x31434D49,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IMC2,0x32434D49,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IMC3,0x33434D49,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IMC4,0x34434D49,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_S340,0x30343353,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_S342,0x32343353,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Overlay,0xe436eb7f,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG1Packet,0xe436eb80,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG1Payload,0xe436eb81,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG1AudioPayload,0x00000050,0x0000,0x0010,0x80,0x00,0x00,0xAA,0x00,0x38,0x9B,0x71)
+OUR_GUID_ENTRY(MEDIATYPE_MPEG1SystemStream,0xe436eb82,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG1System,0xe436eb84,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG1VideoCD,0xe436eb85,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG1Video,0xe436eb86,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_MPEG1Audio,0xe436eb87,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Avi,0xe436eb88,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Asf,0x3db80f90,0x9412,0x11d1,0xad,0xed,0x0,0x0,0xf8,0x75,0x4b,0x99)
+OUR_GUID_ENTRY(MEDIASUBTYPE_QTMovie,0xe436eb89,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_QTRpza,0x617a7072,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_QTSmc,0x20636d73,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_QTRle,0x20656c72,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_QTJpeg,0x6765706a,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_PCMAudio_Obsolete,0xe436eb8a,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_PCM,0x00000001,0x0000,0x0010,0x80,0x00,0x00,0xAA,0x00,0x38,0x9B,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_WAVE,0xe436eb8b,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AU,0xe436eb8c,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AIFF,0xe436eb8d,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(MEDIASUBTYPE_dvsd,0x64737664,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_dvhd,0x64687664,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_dvsl,0x6c737664,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_dv25,0x35327664,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_dv50,0x30357664,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_dvh1,0x31687664,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Line21_BytePair,0x6e8d4a22,0x310c,0x11d0,0xb7,0x9a,0x0,0xaa,0x0,0x37,0x67,0xa7)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Line21_GOPPacket,0x6e8d4a23,0x310c,0x11d0,0xb7,0x9a,0x0,0xaa,0x0,0x37,0x67,0xa7)
+OUR_GUID_ENTRY(MEDIASUBTYPE_Line21_VBIRawData,0x6e8d4a24,0x310c,0x11d0,0xb7,0x9a,0x0,0xaa,0x0,0x37,0x67,0xa7)
+OUR_GUID_ENTRY(MEDIASUBTYPE_TELETEXT,0xf72a76e3,0xeb0a,0x11d0,0xac,0xe4,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(MEDIASUBTYPE_WSS,0x2791D576,0x8E7A,0x466F,0x9E,0x90,0x5D,0x3F,0x30,0x83,0x73,0x8B)
+OUR_GUID_ENTRY(MEDIASUBTYPE_VPS,0xa1b3f620,0x9792,0x4d8d,0x81,0xa4,0x86,0xaf,0x25,0x77,0x20,0x90)
+OUR_GUID_ENTRY(MEDIASUBTYPE_DRM_Audio,0x00000009,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_IEEE_FLOAT,0x00000003,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_DOLBY_AC3_SPDIF,0x00000092,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_RAW_SPORT,0x00000240,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_SPDIF_TAG_241h,0x00000241,0x0000,0x0010,0x80,0x00,0x00,0xaa,0x00,0x38,0x9b,0x71)
+OUR_GUID_ENTRY(MEDIASUBTYPE_DssVideo,0xa0af4f81,0xe163,0x11d0,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(MEDIASUBTYPE_DssAudio,0xa0af4f82,0xe163,0x11d0,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(MEDIASUBTYPE_VPVideo,0x5a9b6a40,0x1a22,0x11d1,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(MEDIASUBTYPE_VPVBI,0x5a9b6a41,0x1a22,0x11d1,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(CLSID_CaptureGraphBuilder,0xBF87B6E0,0x8C27,0x11d0,0xB3,0xF0,0x0,0xAA,0x00,0x37,0x61,0xC5)
+OUR_GUID_ENTRY(CLSID_CaptureGraphBuilder2,0xBF87B6E1,0x8C27,0x11d0,0xB3,0xF0,0x0,0xAA,0x00,0x37,0x61,0xC5)
+OUR_GUID_ENTRY(CLSID_ProtoFilterGraph,0xe436ebb0,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_SystemClock,0xe436ebb1,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_FilterMapper,0xe436ebb2,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_FilterGraph,0xe436ebb3,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_FilterGraphNoThread,0xe436ebb8,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_MPEG1Doc,0xe4bbd160,0x4269,0x11ce,0x83,0x8d,0x0,0xaa,0x0,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(CLSID_FileSource,0x701722e0,0x8ae3,0x11ce,0xa8,0x5c,0x00,0xaa,0x00,0x2f,0xea,0xb5)
+OUR_GUID_ENTRY(CLSID_MPEG1PacketPlayer,0x26c25940,0x4ca9,0x11ce,0xa8,0x28,0x0,0xaa,0x0,0x2f,0xea,0xb5)
+OUR_GUID_ENTRY(CLSID_MPEG1Splitter,0x336475d0,0x942a,0x11ce,0xa8,0x70,0x00,0xaa,0x00,0x2f,0xea,0xb5)
+OUR_GUID_ENTRY(CLSID_CMpegVideoCodec,0xfeb50740,0x7bef,0x11ce,0x9b,0xd9,0x0,0x0,0xe2,0x2,0x59,0x9c)
+OUR_GUID_ENTRY(CLSID_CMpegAudioCodec,0x4a2286e0,0x7bef,0x11ce,0x9b,0xd9,0x0,0x0,0xe2,0x2,0x59,0x9c)
+OUR_GUID_ENTRY(CLSID_TextRender,0xe30629d3,0x27e5,0x11ce,0x87,0x5d,0x0,0x60,0x8c,0xb7,0x80,0x66)
+OUR_GUID_ENTRY(CLSID_InfTee,0xf8388a40,0xd5bb,0x11d0,0xbe,0x5a,0x0,0x80,0xc7,0x6,0x56,0x8e)
+OUR_GUID_ENTRY(CLSID_AviSplitter,0x1b544c20,0xfd0b,0x11ce,0x8c,0x63,0x0,0xaa,0x00,0x44,0xb5,0x1e)
+OUR_GUID_ENTRY(CLSID_AviReader,0x1b544c21,0xfd0b,0x11ce,0x8c,0x63,0x0,0xaa,0x00,0x44,0xb5,0x1e)
+OUR_GUID_ENTRY(CLSID_VfwCapture,0x1b544c22,0xfd0b,0x11ce,0x8c,0x63,0x0,0xaa,0x00,0x44,0xb5,0x1e)
+OUR_GUID_ENTRY(CLSID_CaptureProperties,0x1B544c22,0xFD0B,0x11ce,0x8C,0x63,0x00,0xAA,0x00,0x44,0xB5,0x1F)
+OUR_GUID_ENTRY(CLSID_FGControl,0xe436ebb4,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_MOVReader,0x44584800,0xf8ee,0x11ce,0xb2,0xd4,0x00,0xdd,0x1,0x10,0x1b,0x85)
+OUR_GUID_ENTRY(CLSID_QuickTimeParser,0xd51bd5a0,0x7548,0x11cf,0xa5,0x20,0x0,0x80,0xc7,0x7e,0xf5,0x8a)
+OUR_GUID_ENTRY(CLSID_QTDec,0xfdfe9681,0x74a3,0x11d0,0xaf,0xa7,0x0,0xaa,0x0,0xb6,0x7a,0x42)
+OUR_GUID_ENTRY(CLSID_AVIDoc,0xd3588ab0,0x0781,0x11ce,0xb0,0x3a,0x00,0x20,0xaf,0xb,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_VideoRenderer,0x70e102b0,0x5556,0x11ce,0x97,0xc0,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(CLSID_Colour,0x1643e180,0x90f5,0x11ce,0x97,0xd5,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(CLSID_Dither,0x1da08500,0x9edc,0x11cf,0xbc,0x10,0x00,0xaa,0x00,0xac,0x74,0xf6)
+OUR_GUID_ENTRY(CLSID_ModexRenderer,0x7167665,0x5011,0x11cf,0xbf,0x33,0x0,0xaa,0x0,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(CLSID_AudioRender,0xe30629d1,0x27e5,0x11ce,0x87,0x5d,0x0,0x60,0x8c,0xb7,0x80,0x66)
+OUR_GUID_ENTRY(CLSID_AudioProperties,0x05589faf,0xc356,0x11ce,0xbf,0x01,0x0,0xaa,0x0,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(CLSID_DSoundRender,0x79376820,0x07D0,0x11CF,0xA2,0x4D,0x0,0x20,0xAF,0xD7,0x97,0x67)
+OUR_GUID_ENTRY(CLSID_AudioRecord,0xe30629d2,0x27e5,0x11ce,0x87,0x5d,0x0,0x60,0x8c,0xb7,0x80,0x66)
+OUR_GUID_ENTRY(CLSID_AudioInputMixerProperties,0x2ca8ca52,0x3c3f,0x11d2,0xb7,0x3d,0x0,0xc0,0x4f,0xb6,0xbd,0x3d)
+OUR_GUID_ENTRY(CLSID_AVIDec,0xcf49d4e0,0x1115,0x11ce,0xb0,0x3a,0x0,0x20,0xaf,0xb,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_AVIDraw,0xa888df60,0x1e90,0x11cf,0xac,0x98,0x0,0xaa,0x0,0x4c,0xf,0xa9)
+OUR_GUID_ENTRY(CLSID_ACMWrapper,0x6a08cf80,0x0e18,0x11cf,0xa2,0x4d,0x0,0x20,0xaf,0xd7,0x97,0x67)
+OUR_GUID_ENTRY(CLSID_AsyncReader,0xe436ebb5,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_URLReader,0xe436ebb6,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_PersistMonikerPID,0xe436ebb7,0x524f,0x11ce,0x9f,0x53,0x00,0x20,0xaf,0x0b,0xa7,0x70)
+OUR_GUID_ENTRY(CLSID_AVICo,0xd76e2820,0x1563,0x11cf,0xac,0x98,0x0,0xaa,0x0,0x4c,0xf,0xa9)
+OUR_GUID_ENTRY(CLSID_FileWriter,0x8596e5f0,0xda5,0x11d0,0xbd,0x21,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_AviDest,0xe2510970,0xf137,0x11ce,0x8b,0x67,0x0,0xaa,0x0,0xa3,0xf1,0xa6)
+OUR_GUID_ENTRY(CLSID_AviMuxProptyPage,0xc647b5c0,0x157c,0x11d0,0xbd,0x23,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_AviMuxProptyPage1,0xa9ae910,0x85c0,0x11d0,0xbd,0x42,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_AVIMIDIRender,0x07b65360,0xc445,0x11ce,0xaf,0xde,0x00,0xaa,0x00,0x6c,0x14,0xf4)
+OUR_GUID_ENTRY(CLSID_WMAsfReader,0x187463a0,0x5bb7,0x11d3,0xac,0xbe,0x0,0x80,0xc7,0x5e,0x24,0x6e)
+OUR_GUID_ENTRY(CLSID_WMAsfWriter,0x7c23220e,0x55bb,0x11d3,0x8b,0x16,0x0,0xc0,0x4f,0xb6,0xbd,0x3d)
+OUR_GUID_ENTRY(CLSID_MPEG2Demultiplexer,0xafb6c280,0x2c41,0x11d3,0x8a,0x60,0x00,0x00,0xf8,0x1e,0x0e,0x4a)
+OUR_GUID_ENTRY(CLSID_MMSPLITTER,0x3ae86b20,0x7be8,0x11d1,0xab,0xe6,0x00,0xa0,0xc9,0x05,0xf3,0x75)
+OUR_GUID_ENTRY(CLSID_StreamBufferSink,0x2db47ae5,0xcf39,0x43c2,0xb4,0xd6,0xc,0xd8,0xd9,0x9,0x46,0xf4)
+OUR_GUID_ENTRY(CLSID_StreamBufferSource,0xc9f5fe02,0xf851,0x4eb5,0x99,0xee,0xad,0x60,0x2a,0xf1,0xe6,0x19)
+OUR_GUID_ENTRY(CLSID_StreamBufferConfig,0xfa8a68b2,0xc864,0x4ba2,0xad,0x53,0xd3,0x87,0x6a,0x87,0x49,0x4b)
+OUR_GUID_ENTRY(CLSID_Mpeg2VideoStreamAnalyzer,0x6cfad761,0x735d,0x4aa5,0x8a,0xfc,0xaf,0x91,0xa7,0xd6,0x1e,0xba)
+OUR_GUID_ENTRY(CLSID_StreamBufferRecordingAttributes,0xccaa63ac,0x1057,0x4778,0xae,0x92,0x12,0x6,0xab,0x9a,0xce,0xe6)
+OUR_GUID_ENTRY(CLSID_StreamBufferComposeRecording,0xd682c4ba,0xa90a,0x42fe,0xb9,0xe1,0x3,0x10,0x98,0x49,0xc4,0x23)
+OUR_GUID_ENTRY(CLSID_DVVideoCodec,0xb1b77c00,0xc3e4,0x11cf,0xaf,0x79,0x0,0xaa,0x0,0xb6,0x7a,0x42)
+OUR_GUID_ENTRY(CLSID_DVVideoEnc,0x13aa3650,0xbb6f,0x11d0,0xaf,0xb9,0x0,0xaa,0x0,0xb6,0x7a,0x42)
+OUR_GUID_ENTRY(CLSID_DVSplitter,0x4eb31670,0x9fc6,0x11cf,0xaf,0x6e,0x0,0xaa,0x0,0xb6,0x7a,0x42)
+OUR_GUID_ENTRY(CLSID_DVMux,0x129d7e40,0xc10d,0x11d0,0xaf,0xb9,0x0,0xaa,0x0,0xb6,0x7a,0x42)
+OUR_GUID_ENTRY(CLSID_SeekingPassThru,0x60af76c,0x68dd,0x11d0,0x8f,0xc1,0x0,0xc0,0x4f,0xd9,0x18,0x9d)
+OUR_GUID_ENTRY(CLSID_Line21Decoder,0x6e8d4a20,0x310c,0x11d0,0xb7,0x9a,0x0,0xaa,0x0,0x37,0x67,0xa7)
+OUR_GUID_ENTRY(CLSID_Line21Decoder2,0xe4206432,0x01a1,0x4bee,0xb3,0xe1,0x37,0x02,0xc8,0xed,0xc5,0x74)
+OUR_GUID_ENTRY(CLSID_OverlayMixer,0xcd8743a1,0x3736,0x11d0,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+OUR_GUID_ENTRY(CLSID_VBISurfaces,0x814b9800,0x1c88,0x11d1,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(CLSID_WSTDecoder,0x70bc06e0,0x5666,0x11d3,0xa1,0x84,0x0,0x10,0x5a,0xef,0x9f,0x33)
+OUR_GUID_ENTRY(CLSID_MjpegDec,0x301056d0,0x6dff,0x11d2,0x9e,0xeb,0x0,0x60,0x8,0x3,0x9e,0x37)
+OUR_GUID_ENTRY(CLSID_MJPGEnc,0xb80ab0a0,0x7416,0x11d2,0x9e,0xeb,0x0,0x60,0x8,0x3,0x9e,0x37)
+OUR_GUID_ENTRY(CLSID_SystemDeviceEnum,0x62BE5D10,0x60EB,0x11d0,0xBD,0x3B,0x00,0xA0,0xC9,0x11,0xCE,0x86)
+OUR_GUID_ENTRY(CLSID_CDeviceMoniker,0x4315D437,0x5B8C,0x11d0,0xBD,0x3B,0x00,0xA0,0xC9,0x11,0xCE,0x86)
+OUR_GUID_ENTRY(CLSID_VideoInputDeviceCategory,0x860BB310,0x5D01,0x11d0,0xBD,0x3B,0x00,0xA0,0xC9,0x11,0xCE,0x86)
+OUR_GUID_ENTRY(CLSID_CVidCapClassManager,0x860BB310,0x5D01,0x11d0,0xBD,0x3B,0x00,0xA0,0xC9,0x11,0xCE,0x86)
+OUR_GUID_ENTRY(CLSID_LegacyAmFilterCategory,0x083863F1,0x70DE,0x11d0,0xBD,0x40,0x00,0xA0,0xC9,0x11,0xCE,0x86)
+OUR_GUID_ENTRY(CLSID_CQzFilterClassManager,0x083863F1,0x70DE,0x11d0,0xBD,0x40,0x00,0xA0,0xC9,0x11,0xCE,0x86)
+OUR_GUID_ENTRY(CLSID_VideoCompressorCategory,0x33d9a760,0x90c8,0x11d0,0xbd,0x43,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_CIcmCoClassManager,0x33d9a760,0x90c8,0x11d0,0xbd,0x43,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_AudioCompressorCategory,0x33d9a761,0x90c8,0x11d0,0xbd,0x43,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_CAcmCoClassManager,0x33d9a761,0x90c8,0x11d0,0xbd,0x43,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_AudioInputDeviceCategory,0x33d9a762,0x90c8,0x11d0,0xbd,0x43,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_CWaveinClassManager,0x33d9a762,0x90c8,0x11d0,0xbd,0x43,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_AudioRendererCategory,0xe0f158e1,0xcb04,0x11d0,0xbd,0x4e,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_CWaveOutClassManager,0xe0f158e1,0xcb04,0x11d0,0xbd,0x4e,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_MidiRendererCategory,0x4EfE2452,0x168A,0x11d1,0xBC,0x76,0x0,0xc0,0x4F,0xB9,0x45,0x3B)
+OUR_GUID_ENTRY(CLSID_CMidiOutClassManager,0x4EfE2452,0x168A,0x11d1,0xBC,0x76,0x0,0xc0,0x4F,0xB9,0x45,0x3B)
+OUR_GUID_ENTRY(CLSID_TransmitCategory,0xcc7bfb41,0xf175,0x11d1,0xa3,0x92,0x0,0xe0,0x29,0x1f,0x39,0x59)
+OUR_GUID_ENTRY(CLSID_DeviceControlCategory,0xcc7bfb46,0xf175,0x11d1,0xa3,0x92,0x0,0xe0,0x29,0x1f,0x39,0x59)
+OUR_GUID_ENTRY(CLSID_ActiveMovieCategories,0xda4e3da0,0xd07d,0x11d0,0xbd,0x50,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_DVDHWDecodersCategory,0x2721AE20,0x7E70,0x11D0,0xA5,0xD6,0x28,0xDB,0x04,0xC1,0x00,0x00)
+OUR_GUID_ENTRY(CLSID_MediaEncoderCategory,0x7D22E920,0x5CA9,0x4787,0x8C,0x2B,0xA6,0x77,0x9B,0xD1,0x17,0x81)
+OUR_GUID_ENTRY(CLSID_MediaMultiplexerCategory,0x236C9559,0xADCE,0x4736,0xBF,0x72,0xBA,0xB3,0x4E,0x39,0x21,0x96)
+OUR_GUID_ENTRY(CLSID_FilterMapper2,0xcda42200,0xbd88,0x11d0,0xbd,0x4e,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_MemoryAllocator,0x1e651cc0,0xb199,0x11d0,0x82,0x12,0x00,0xc0,0x4f,0xc3,0x2c,0x45)
+OUR_GUID_ENTRY(CLSID_MediaPropertyBag,0xcdbd8d00,0xc193,0x11d0,0xbd,0x4e,0x0,0xa0,0xc9,0x11,0xce,0x86)
+OUR_GUID_ENTRY(CLSID_DvdGraphBuilder,0xFCC152B7,0xF372,0x11d0,0x8E,0x00,0x00,0xC0,0x4F,0xD7,0xC0,0x8B)
+OUR_GUID_ENTRY(CLSID_DVDNavigator,0x9b8c4620,0x2c1a,0x11d0,0x84,0x93,0x0,0xa0,0x24,0x38,0xad,0x48)
+OUR_GUID_ENTRY(CLSID_DVDState,0xf963c5cf,0xa659,0x4a93,0x96,0x38,0xca,0xf3,0xcd,0x27,0x7d,0x13)
+OUR_GUID_ENTRY(CLSID_SmartTee,0xcc58e280,0x8aa1,0x11d1,0xb3,0xf1,0x0,0xaa,0x0,0x37,0x61,0xc5)
+OUR_GUID_ENTRY(FORMAT_None,0x0F6417D6,0xc318,0x11d0,0xa4,0x3f,0x00,0xa0,0xc9,0x22,0x31,0x96)
+OUR_GUID_ENTRY(FORMAT_VideoInfo,0x05589f80,0xc356,0x11ce,0xbf,0x01,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(FORMAT_VideoInfo2,0xf72a76A0,0xeb0a,0x11d0,0xac,0xe4,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(FORMAT_WaveFormatEx,0x05589f81,0xc356,0x11ce,0xbf,0x01,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(FORMAT_MPEGVideo,0x05589f82,0xc356,0x11ce,0xbf,0x01,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(FORMAT_MPEGStreams,0x05589f83,0xc356,0x11ce,0xbf,0x01,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(FORMAT_DvInfo,0x05589f84,0xc356,0x11ce,0xbf,0x01,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(CLSID_DirectDrawProperties,0x944d4c00,0xdd52,0x11ce,0xbf,0x0e,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(CLSID_PerformanceProperties,0x59ce6880,0xacf8,0x11cf,0xb5,0x6e,0x00,0x80,0xc7,0xc4,0xb6,0x8a)
+OUR_GUID_ENTRY(CLSID_QualityProperties,0x418afb70,0xf8b8,0x11ce,0xaa,0xc6,0x00,0x20,0xaf,0x0b,0x99,0xa3)
+OUR_GUID_ENTRY(IID_IBaseVideoMixer,0x61ded640,0xe912,0x11ce,0xa0,0x99,0x00,0xaa,0x00,0x47,0x9a,0x58)
+OUR_GUID_ENTRY(IID_IDirectDrawVideo,0x36d39eb0,0xdd75,0x11ce,0xbf,0x0e,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(IID_IQualProp,0x1bd0ecb0,0xf8e2,0x11ce,0xaa,0xc6,0x00,0x20,0xaf,0x0b,0x99,0xa3)
+OUR_GUID_ENTRY(CLSID_VPObject,0xce292861,0xfc88,0x11d0,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+OUR_GUID_ENTRY(IID_IVPObject,0xce292862,0xfc88,0x11d0,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+OUR_GUID_ENTRY(IID_IVPControl,0x25df12c1,0x3de0,0x11d1,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+OUR_GUID_ENTRY(CLSID_VPVBIObject,0x814b9801,0x1c88,0x11d1,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(IID_IVPVBIObject,0x814b9802,0x1c88,0x11d1,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(IID_IVPConfig,0xbc29a660,0x30e3,0x11d0,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+OUR_GUID_ENTRY(IID_IVPNotify,0xc76794a1,0xd6c5,0x11d0,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+OUR_GUID_ENTRY(IID_IVPNotify2,0xebf47183,0x8764,0x11d1,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+OUR_GUID_ENTRY(IID_IVPVBIConfig,0xec529b00,0x1a1f,0x11d1,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(IID_IVPVBINotify,0xec529b01,0x1a1f,0x11d1,0xba,0xd9,0x0,0x60,0x97,0x44,0x11,0x1a)
+OUR_GUID_ENTRY(IID_IMixerPinConfig,0x593cdde1,0x759,0x11d1,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+OUR_GUID_ENTRY(IID_IMixerPinConfig2,0xebf47182,0x8764,0x11d1,0x9e,0x69,0x0,0xc0,0x4f,0xd7,0xc1,0x5b)
+#ifndef __DDRAW_INCLUDED__
+OUR_GUID_ENTRY(CLSID_DirectDraw,0xD7B70EE0,0x4340,0x11CF,0xB0,0x63,0x00,0x20,0xAF,0xC2,0xCD,0x35)
+OUR_GUID_ENTRY(CLSID_DirectDrawClipper,0x593817A0,0x7DB3,0x11CF,0xA2,0xDE,0x00,0xAA,0x00,0xb9,0x33,0x56)
+OUR_GUID_ENTRY(IID_IDirectDraw,0x6C14DB80,0xA733,0x11CE,0xA5,0x21,0x00,0x20,0xAF,0x0B,0xE5,0x60)
+OUR_GUID_ENTRY(IID_IDirectDraw2,0xB3A6F3E0,0x2B43,0x11CF,0xA2,0xDE,0x00,0xAA,0x00,0xB9,0x33,0x56)
+OUR_GUID_ENTRY(IID_IDirectDrawSurface,0x6C14DB81,0xA733,0x11CE,0xA5,0x21,0x00,0x20,0xAF,0x0B,0xE5,0x60)
+OUR_GUID_ENTRY(IID_IDirectDrawSurface2,0x57805885,0x6eec,0x11cf,0x94,0x41,0xa8,0x23,0x03,0xc1,0x0e,0x27)
+OUR_GUID_ENTRY(IID_IDirectDrawSurface3,0xDA044E00,0x69B2,0x11D0,0xA1,0xD5,0x00,0xAA,0x00,0xB8,0xDF,0xBB)
+OUR_GUID_ENTRY(IID_IDirectDrawSurface4,0x0B2B8630,0xAD35,0x11D0,0x8E,0xA6,0x00,0x60,0x97,0x97,0xEA,0x5B)
+OUR_GUID_ENTRY(IID_IDirectDrawSurface7,0x06675a80,0x3b9b,0x11d2,0xb9,0x2f,0x00,0x60,0x97,0x97,0xea,0x5b)
+OUR_GUID_ENTRY(IID_IDirectDrawPalette,0x6C14DB84,0xA733,0x11CE,0xA5,0x21,0x00,0x20,0xAF,0x0B,0xE5,0x60)
+OUR_GUID_ENTRY(IID_IDirectDrawClipper,0x6C14DB85,0xA733,0x11CE,0xA5,0x21,0x00,0x20,0xAF,0x0B,0xE5,0x60)
+OUR_GUID_ENTRY(IID_IDirectDrawColorControl,0x4B9F0EE0,0x0D7E,0x11D0,0x9B,0x06,0x00,0xA0,0xC9,0x03,0xA3,0xB8)
+#endif
+#ifndef __DVP_INCLUDED__
+OUR_GUID_ENTRY(IID_IDDVideoPortContainer,0x6C142760,0xA733,0x11CE,0xA5,0x21,0x00,0x20,0xAF,0x0B,0xE5,0x60)
+#endif
+#ifndef __DDKM_INCLUDED__
+OUR_GUID_ENTRY(IID_IDirectDrawKernel,0x8D56C120,0x6A08,0x11D0,0x9B,0x06,0x00,0xA0,0xC9,0x03,0xA3,0xB8)
+OUR_GUID_ENTRY(IID_IDirectDrawSurfaceKernel,0x60755DA0,0x6A40,0x11D0,0x9B,0x06,0x00,0xA0,0xC9,0x03,0xA3,0xB8)
+#endif
+OUR_GUID_ENTRY(CLSID_ModexProperties,0x0618aa30,0x6bc4,0x11cf,0xbf,0x36,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(IID_IFullScreenVideo,0xdd1d7110,0x7836,0x11cf,0xbf,0x47,0x00,0xaa,0x00,0x55,0x59,0x5a)
+OUR_GUID_ENTRY(IID_IFullScreenVideoEx,0x53479470,0xf1dd,0x11cf,0xbc,0x42,0x00,0xaa,0x00,0xac,0x74,0xf6)
+OUR_GUID_ENTRY(CLSID_DVDecPropertiesPage,0x101193c0,0xbfe,0x11d0,0xaf,0x91,0x0,0xaa,0x0,0xb6,0x7a,0x42)
+OUR_GUID_ENTRY(CLSID_DVEncPropertiesPage,0x4150f050,0xbb6f,0x11d0,0xaf,0xb9,0x0,0xaa,0x0,0xb6,0x7a,0x42)
+OUR_GUID_ENTRY(CLSID_DVMuxPropertyPage,0x4db880e0,0xc10d,0x11d0,0xaf,0xb9,0x0,0xaa,0x0,0xb6,0x7a,0x42)
+OUR_GUID_ENTRY(IID_IAMDirectSound,0x546f4260,0xd53e,0x11cf,0xb3,0xf0,0x0,0xaa,0x0,0x37,0x61,0xc5)
+OUR_GUID_ENTRY(IID_IMpegAudioDecoder,0xb45dd570,0x3c77,0x11d1,0xab,0xe1,0x00,0xa0,0xc9,0x05,0xf3,0x75)
+OUR_GUID_ENTRY(IID_IAMLine21Decoder,0x6e8d4a21,0x310c,0x11d0,0xb7,0x9a,0x0,0xaa,0x0,0x37,0x67,0xa7)
+OUR_GUID_ENTRY(IID_IAMWstDecoder,0xc056de21,0x75c2,0x11d3,0xa1,0x84,0x0,0x10,0x5a,0xef,0x9f,0x33)
+OUR_GUID_ENTRY(CLSID_WstDecoderPropertyPage,0x4e27f80,0x91e4,0x11d3,0xa1,0x84,0x0,0x10,0x5a,0xef,0x9f,0x33)
+OUR_GUID_ENTRY(FORMAT_AnalogVideo,0x482dde0,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIATYPE_AnalogVideo,0x482dde1,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_NTSC_M,0x482dde2,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_PAL_B,0x482dde5,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_PAL_D,0x482dde6,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_PAL_G,0x482dde7,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_PAL_H,0x482dde8,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_PAL_I,0x482dde9,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_PAL_M,0x482ddea,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_PAL_N,0x482ddeb,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_PAL_N_COMBO,0x482ddec,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_SECAM_B,0x482ddf0,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_SECAM_D,0x482ddf1,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_SECAM_G,0x482ddf2,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_SECAM_H,0x482ddf3,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_SECAM_K,0x482ddf4,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_SECAM_K1,0x482ddf5,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIASUBTYPE_AnalogVideo_SECAM_L,0x482ddf6,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(MEDIATYPE_AnalogAudio,0x482dee1,0x7817,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+
+#include "dshow/ksuuids.h"
+
+OUR_GUID_ENTRY(TIME_FORMAT_NONE,0L,0,0,0,0,0,0,0,0,0,0)
+OUR_GUID_ENTRY(TIME_FORMAT_FRAME,0x7b785570,0x8c82,0x11cf,0xbc,0xc,0x0,0xaa,0x0,0xac,0x74,0xf6)
+OUR_GUID_ENTRY(TIME_FORMAT_BYTE,0x7b785571,0x8c82,0x11cf,0xbc,0xc,0x0,0xaa,0x0,0xac,0x74,0xf6)
+OUR_GUID_ENTRY(TIME_FORMAT_SAMPLE,0x7b785572,0x8c82,0x11cf,0xbc,0xc,0x0,0xaa,0x0,0xac,0x74,0xf6)
+OUR_GUID_ENTRY(TIME_FORMAT_FIELD,0x7b785573,0x8c82,0x11cf,0xbc,0xc,0x0,0xaa,0x0,0xac,0x74,0xf6)
+OUR_GUID_ENTRY(TIME_FORMAT_MEDIA_TIME,0x7b785574,0x8c82,0x11cf,0xbc,0xc,0x0,0xaa,0x0,0xac,0x74,0xf6)
+OUR_GUID_ENTRY(AMPROPSETID_Pin,0x9b00f101,0x1567,0x11d1,0xb3,0xf1,0x0,0xaa,0x0,0x37,0x61,0xc5)
+OUR_GUID_ENTRY(PIN_CATEGORY_CAPTURE,0xfb6c4281,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_PREVIEW,0xfb6c4282,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_ANALOGVIDEOIN,0xfb6c4283,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_VBI,0xfb6c4284,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_VIDEOPORT,0xfb6c4285,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_NABTS,0xfb6c4286,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_EDS,0xfb6c4287,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_TELETEXT,0xfb6c4288,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_CC,0xfb6c4289,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_STILL,0xfb6c428a,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_TIMECODE,0xfb6c428b,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(PIN_CATEGORY_VIDEOPORT_VBI,0xfb6c428c,0x0353,0x11d1,0x90,0x5f,0x00,0x00,0xc0,0xcc,0x16,0xba)
+OUR_GUID_ENTRY(LOOK_UPSTREAM_ONLY,0xac798be0,0x98e3,0x11d1,0xb3,0xf1,0x0,0xaa,0x0,0x37,0x61,0xc5)
+OUR_GUID_ENTRY(LOOK_DOWNSTREAM_ONLY,0xac798be1,0x98e3,0x11d1,0xb3,0xf1,0x0,0xaa,0x0,0x37,0x61,0xc5)
+OUR_GUID_ENTRY(CLSID_TVTunerFilterPropertyPage,0x266eee41,0x6c63,0x11cf,0x8a,0x3,0x0,0xaa,0x0,0x6e,0xcb,0x65)
+OUR_GUID_ENTRY(CLSID_CrossbarFilterPropertyPage,0x71f96461,0x78f3,0x11d0,0xa1,0x8c,0x0,0xa0,0xc9,0x11,0x89,0x56)
+OUR_GUID_ENTRY(CLSID_TVAudioFilterPropertyPage,0x71f96463,0x78f3,0x11d0,0xa1,0x8c,0x0,0xa0,0xc9,0x11,0x89,0x56)
+OUR_GUID_ENTRY(CLSID_VideoProcAmpPropertyPage,0x71f96464,0x78f3,0x11d0,0xa1,0x8c,0x0,0xa0,0xc9,0x11,0x89,0x56)
+OUR_GUID_ENTRY(CLSID_CameraControlPropertyPage,0x71f96465,0x78f3,0x11d0,0xa1,0x8c,0x0,0xa0,0xc9,0x11,0x89,0x56)
+OUR_GUID_ENTRY(CLSID_AnalogVideoDecoderPropertyPage,0x71f96466,0x78f3,0x11d0,0xa1,0x8c,0x0,0xa0,0xc9,0x11,0x89,0x56)
+OUR_GUID_ENTRY(CLSID_VideoStreamConfigPropertyPage,0x71f96467,0x78f3,0x11d0,0xa1,0x8c,0x0,0xa0,0xc9,0x11,0x89,0x56)
+OUR_GUID_ENTRY(CLSID_AudioRendererAdvancedProperties,0x37e92a92,0xd9aa,0x11d2,0xbf,0x84,0x8e,0xf2,0xb1,0x55,0x5a,0xed)
+OUR_GUID_ENTRY(CLSID_VideoMixingRenderer,0xB87BEB7B,0x8D29,0x423f,0xAE,0x4D,0x65,0x82,0xC1,0x01,0x75,0xAC)
+OUR_GUID_ENTRY(CLSID_VideoRendererDefault,0x6BC1CFFA,0x8FC1,0x4261,0xAC,0x22,0xCF,0xB4,0xCC,0x38,0xDB,0x50)
+OUR_GUID_ENTRY(CLSID_AllocPresenter,0x99d54f63,0x1a69,0x41ae,0xaa,0x4d,0xc9,0x76,0xeb,0x3f,0x07,0x13)
+OUR_GUID_ENTRY(CLSID_AllocPresenterDDXclMode,0x4444ac9e,0x242e,0x471b,0xa3,0xc7,0x45,0xdc,0xd4,0x63,0x52,0xbc)
+OUR_GUID_ENTRY(CLSID_VideoPortManager,0x6f26a6cd,0x967b,0x47fd,0x87,0x4a,0x7a,0xed,0x2c,0x9d,0x25,0xa2)
+OUR_GUID_ENTRY(CLSID_VideoMixingRenderer9,0x51b4abf3,0x748f,0x4e3b,0xa2,0x76,0xc8,0x28,0x33,0x0e,0x92,0x6a)
+OUR_GUID_ENTRY(CLSID_ATSCNetworkProvider,0x0dad2fdd,0x5fd7,0x11d3,0x8f,0x50,0x00,0xc0,0x4f,0x79,0x71,0xe2)
+OUR_GUID_ENTRY(CLSID_ATSCNetworkPropertyPage,0xe3444d16,0x5ac4,0x4386,0x88,0xdf,0x13,0xfd,0x23,0x0e,0x1d,0xda)
+OUR_GUID_ENTRY(CLSID_DVBSNetworkProvider,0xfa4b375a,0x45b4,0x4d45,0x84,0x40,0x26,0x39,0x57,0xb1,0x16,0x23)
+OUR_GUID_ENTRY(CLSID_DVBTNetworkProvider,0x216c62df,0x6d7f,0x4e9a,0x85,0x71,0x5,0xf1,0x4e,0xdb,0x76,0x6a)
+OUR_GUID_ENTRY(CLSID_DVBCNetworkProvider,0xdc0c0fe7,0x485,0x4266,0xb9,0x3f,0x68,0xfb,0xf8,0xe,0xd8,0x34)
+OUR_GUID_ENTRY(CLSID_DShowTVEFilter,0x05500280,0xFAA5,0x4DF9,0x82,0x46,0xBF,0xC2,0x3A,0xC5,0xCE,0xA8)
+OUR_GUID_ENTRY(CLSID_TVEFilterTuneProperties,0x05500281,0xFAA5,0x4DF9,0x82,0x46,0xBF,0xC2,0x3A,0xC5,0xCE,0xA8)
+OUR_GUID_ENTRY(CLSID_TVEFilterCCProperties,0x05500282,0xFAA5,0x4DF9,0x82,0x46,0xBF,0xC2,0x3A,0xC5,0xCE,0xA8)
+OUR_GUID_ENTRY(CLSID_TVEFilterStatsProperties,0x05500283,0xFAA5,0x4DF9,0x82,0x46,0xBF,0xC2,0x3A,0xC5,0xCE,0xA8)
+OUR_GUID_ENTRY(CLSID_IVideoEncoderProxy,0xb43c4eec,0x8c32,0x4791,0x91,0x2,0x50,0x8a,0xda,0x5e,0xe8,0xe7)
+OUR_GUID_ENTRY(CLSID_ICodecAPIProxy,0x7ff0997a,0x1999,0x4286,0xa7,0x3c,0x62,0x2b,0x88,0x14,0xe7,0xeb)
+OUR_GUID_ENTRY(CLSID_IVideoEncoderCodecAPIProxy,0xb05dabd9,0x56e5,0x4fdc,0xaf,0xa4,0x8a,0x47,0xe9,0x1f,0x1c,0x9c)
+
+#ifndef __ENCODER_API_GUIDS__
+#define __ENCODER_API_GUIDS__
+OUR_GUID_ENTRY(ENCAPIPARAM_BITRATE,0x49cc4c43,0xca83,0x4ad4,0xa9,0xaf,0xf3,0x69,0x6a,0xf6,0x66,0xdf)
+OUR_GUID_ENTRY(ENCAPIPARAM_PEAK_BITRATE,0x703f16a9,0x3d48,0x44a1,0xb0,0x77,0x1,0x8d,0xff,0x91,0x5d,0x19)
+OUR_GUID_ENTRY(ENCAPIPARAM_BITRATE_MODE,0xee5fb25c,0xc713,0x40d1,0x9d,0x58,0xc0,0xd7,0x24,0x1e,0x25,0xf)
+OUR_GUID_ENTRY(CODECAPI_CHANGELISTS,0x62b12acf,0xf6b0,0x47d9,0x94,0x56,0x96,0xf2,0x2c,0x4e,0x0b,0x9d)
+OUR_GUID_ENTRY(CODECAPI_VIDEO_ENCODER,0x7112e8e1,0x3d03,0x47ef,0x8e,0x60,0x03,0xf1,0xcf,0x53,0x73,0x01)
+OUR_GUID_ENTRY(CODECAPI_AUDIO_ENCODER,0xb9d19a3e,0xf897,0x429c,0xbc,0x46,0x81,0x38,0xb7,0x27,0x2b,0x2d)
+OUR_GUID_ENTRY(CODECAPI_SETALLDEFAULTS,0x6c5e6a7c,0xacf8,0x4f55,0xa9,0x99,0x1a,0x62,0x81,0x09,0x05,0x1b)
+OUR_GUID_ENTRY(CODECAPI_ALLSETTINGS,0x6a577e92,0x83e1,0x4113,0xad,0xc2,0x4f,0xce,0xc3,0x2f,0x83,0xa1)
+OUR_GUID_ENTRY(CODECAPI_SUPPORTSEVENTS,0x0581af97,0x7693,0x4dbd,0x9d,0xca,0x3f,0x9e,0xbd,0x65,0x85,0xa1)
+OUR_GUID_ENTRY(CODECAPI_CURRENTCHANGELIST,0x1cb14e83,0x7d72,0x4657,0x83,0xfd,0x47,0xa2,0xc5,0xb9,0xd1,0x3d)
+#endif
+
+#undef OUR_GUID_ENTRY

3rdparty/include/f2c.h

@@ -1,253 +0,0 @@
-/* f2c.h  --  Standard Fortran to C header file */
-
-/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
-
-	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
-
-#ifndef F2C_INCLUDE
-#define F2C_INCLUDE
-
-#include <assert.h>
-#include <math.h>
-#include <ctype.h>
-#include <stdlib.h>
-/* needed for Windows Mobile */
-#ifdef WINCE
-#undef complex; 
-#endif
-#include <string.h>
-#include <stdio.h>
-
-#if __SSE2__ || defined _M_X64
-#include "emmintrin.h"
-#endif
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-typedef int integer;
-typedef unsigned int uinteger;
-typedef char *address;
-typedef short int shortint;
-typedef float real;
-typedef double doublereal;
-typedef struct { real r, i; } complex;
-typedef struct { doublereal r, i; } doublecomplex;
-typedef int logical;
-typedef short int shortlogical;
-typedef char logical1;
-typedef char integer1;
-#ifdef INTEGER_STAR_8	/* Adjust for integer*8. */
-typedef long long longint;		/* system-dependent */
-typedef unsigned long long ulongint;	/* system-dependent */
-#define qbit_clear(a,b)	((a) & ~((ulongint)1 << (b)))
-#define qbit_set(a,b)	((a) |  ((ulongint)1 << (b)))
-#endif
-
-#define TRUE_ (1)
-#define FALSE_ (0)
-
-/* Extern is for use with -E */
-#ifndef Extern
-#define Extern extern
-#endif
-
-/* I/O stuff */
-
-#ifdef f2c_i2
-/* for -i2 */
-typedef short flag;
-typedef short ftnlen;
-typedef short ftnint;
-#else
-typedef int flag;
-typedef int ftnlen;
-typedef int ftnint;
-#endif
-
-/*external read, write*/
-typedef struct
-{	flag cierr;
-	ftnint ciunit;
-	flag ciend;
-	char *cifmt;
-	ftnint cirec;
-} cilist;
-
-/*internal read, write*/
-typedef struct
-{	flag icierr;
-	char *iciunit;
-	flag iciend;
-	char *icifmt;
-	ftnint icirlen;
-	ftnint icirnum;
-} icilist;
-
-/*open*/
-typedef struct
-{	flag oerr;
-	ftnint ounit;
-	char *ofnm;
-	ftnlen ofnmlen;
-	char *osta;
-	char *oacc;
-	char *ofm;
-	ftnint orl;
-	char *oblnk;
-} olist;
-
-/*close*/
-typedef struct
-{	flag cerr;
-	ftnint cunit;
-	char *csta;
-} cllist;
-
-/*rewind, backspace, endfile*/
-typedef struct
-{	flag aerr;
-	ftnint aunit;
-} alist;
-
-/* inquire */
-typedef struct
-{	flag inerr;
-	ftnint inunit;
-	char *infile;
-	ftnlen infilen;
-	ftnint	*inex;	/*parameters in standard's order*/
-	ftnint	*inopen;
-	ftnint	*innum;
-	ftnint	*innamed;
-	char	*inname;
-	ftnlen	innamlen;
-	char	*inacc;
-	ftnlen	inacclen;
-	char	*inseq;
-	ftnlen	inseqlen;
-	char 	*indir;
-	ftnlen	indirlen;
-	char	*infmt;
-	ftnlen	infmtlen;
-	char	*inform;
-	ftnint	informlen;
-	char	*inunf;
-	ftnlen	inunflen;
-	ftnint	*inrecl;
-	ftnint	*innrec;
-	char	*inblank;
-	ftnlen	inblanklen;
-} inlist;
-
-#define VOID void
-
-union Multitype {	/* for multiple entry points */
-	integer1 g;
-	shortint h;
-	integer i;
-	/* longint j; */
-	real r;
-	doublereal d;
-	complex c;
-	doublecomplex z;
-	};
-
-typedef union Multitype Multitype;
-
-/*typedef long int Long;*/	/* No longer used; formerly in Namelist */
-
-struct Vardesc {	/* for Namelist */
-	char *name;
-	char *addr;
-	ftnlen *dims;
-	int  type;
-	};
-typedef struct Vardesc Vardesc;
-
-struct Namelist {
-	char *name;
-	Vardesc **vars;
-	int nvars;
-	};
-typedef struct Namelist Namelist;
-
-#ifndef abs
-#define abs(x) ((x) >= 0 ? (x) : -(x))
-#endif
-#define dabs(x) (doublereal)abs(x)
-#ifndef min
-#define min(a,b) ((a) <= (b) ? (a) : (b))
-#endif
-#ifndef max
-#define max(a,b) ((a) >= (b) ? (a) : (b))
-#endif
-#define dmin(a,b) (doublereal)min(a,b)
-#define dmax(a,b) (doublereal)max(a,b)
-#define bit_test(a,b)	((a) >> (b) & 1)
-#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
-#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
-
-/* procedure parameter types for -A and -C++ */
-
-#define F2C_proc_par_types 1
-#ifdef __cplusplus
-typedef int /* Unknown procedure type */ (*U_fp)(...);
-typedef shortint (*J_fp)(...);
-typedef integer (*I_fp)(...);
-typedef real (*R_fp)(...);
-typedef doublereal (*D_fp)(...), (*E_fp)(...);
-typedef /* Complex */ VOID (*C_fp)(...);
-typedef /* Double Complex */ VOID (*Z_fp)(...);
-typedef logical (*L_fp)(...);
-typedef shortlogical (*K_fp)(...);
-typedef /* Character */ VOID (*H_fp)(...);
-typedef /* Subroutine */ int (*S_fp)(...);
-#else
-typedef int /* Unknown procedure type */ (*U_fp)();
-typedef shortint (*J_fp)();
-typedef integer (*I_fp)();
-typedef real (*R_fp)();
-typedef doublereal (*D_fp)(), (*E_fp)();
-typedef /* Complex */ VOID (*C_fp)();
-typedef /* Double Complex */ VOID (*Z_fp)();
-typedef logical (*L_fp)();
-typedef shortlogical (*K_fp)();
-typedef /* Character */ VOID (*H_fp)();
-typedef /* Subroutine */ int (*S_fp)();
-#endif
-/* E_fp is for real functions when -R is not specified */
-typedef VOID C_f;	/* complex function */
-typedef VOID H_f;	/* character function */
-typedef VOID Z_f;	/* double complex function */
-typedef doublereal E_f;	/* real function with -R not specified */
-
-/* undef any lower-case symbols that your C compiler predefines, e.g.: */
-
-#ifndef Skip_f2c_Undefs
-#undef cray
-#undef gcos
-#undef mc68010
-#undef mc68020
-#undef mips
-#undef pdp11
-#undef sgi
-#undef sparc
-#undef sun
-#undef sun2
-#undef sun3
-#undef sun4
-#undef u370
-#undef u3b
-#undef u3b2
-#undef u3b5
-#undef unix
-#undef vax
-#endif
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif

3rdparty/include/videoInput.h

@@ -1,385 +0,0 @@
-#ifndef _VIDEOINPUT
-#define _VIDEOINPUT
-
-//THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-//IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-//FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-//AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-//LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-//OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
-//THE SOFTWARE.
-
-//////////////////////////////////////////////////////////
-//Written by Theodore Watson - theo.watson@gmail.com    //
-//Do whatever you want with this code but if you find   //
-//a bug or make an improvement I would love to know!    //
-//														//
-//Warning This code is experimental 					//
-//use at your own risk :)								//
-//////////////////////////////////////////////////////////
-/////////////////////////////////////////////////////////
-/*                     Shoutouts 
-
-Thanks to: 
-			
-		   Dillip Kumar Kara for crossbar code.
-		   Zachary Lieberman for getting me into this stuff
-		   and for being so generous with time and code.
-		   The guys at Potion Design for helping me with VC++
-		   Josh Fisher for being a serious C++ nerd :)
-		   Golan Levin for helping me debug the strangest 
-		   and slowest bug in the world!
-		   
-		   And all the people using this library who send in 
-		   bugs, suggestions and improvements who keep me working on 
-		   the next version - yeah thanks a lot ;)
-		   
-*/
-/////////////////////////////////////////////////////////
-
-
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <math.h>
-#include <string.h>
-#include <wchar.h>
-
-//this is for TryEnterCriticalSection
-#ifndef _WIN32_WINNT
-	#   define _WIN32_WINNT 0x400
-#endif
-#include <windows.h>
-
-
-//Example Usage
-/*
-	//create a videoInput object
-	videoInput VI;
-	
-	//Prints out a list of available devices and returns num of devices found
-	int numDevices = VI.listDevices();	
-	
-	int device1 = 0;  //this could be any deviceID that shows up in listDevices
-	int device2 = 1;  //this could be any deviceID that shows up in listDevices
-	
-	//if you want to capture at a different frame rate (default is 30) 
-	//specify it here, you are not guaranteed to get this fps though.
-	//VI.setIdealFramerate(dev, 60);	
-	
-	//setup the first device - there are a number of options:
-	
-	VI.setupDevice(device1); 						  //setup the first device with the default settings
-	//VI.setupDevice(device1, VI_COMPOSITE); 			  //or setup device with specific connection type
-	//VI.setupDevice(device1, 320, 240);				  //or setup device with specified video size
-	//VI.setupDevice(device1, 320, 240, VI_COMPOSITE);  //or setup device with video size and connection type
-
-	//VI.setFormat(device1, VI_NTSC_M);					//if your card doesn't remember what format it should be
-														//call this with the appropriate format listed above
-														//NOTE: must be called after setupDevice!
-	
-	//optionally setup a second (or third, fourth ...) device - same options as above
-	VI.setupDevice(device2); 						  
-
-	//As requested width and height can not always be accomodated
-	//make sure to check the size once the device is setup
-
-	int width 	= VI.getWidth(device1);
-	int height 	= VI.getHeight(device1);
-	int size	= VI.getSize(device1);
-	
-	unsigned char * yourBuffer1 = new unsigned char[size];
-	unsigned char * yourBuffer2 = new unsigned char[size];
-	
-	//to get the data from the device first check if the data is new
-	if(VI.isFrameNew(device1)){
-		VI.getPixels(device1, yourBuffer1, false, false);	//fills pixels as a BGR (for openCV) unsigned char array - no flipping
-		VI.getPixels(device1, yourBuffer2, true, true); 	//fills pixels as a RGB (for openGL) unsigned char array - flipping!
-	}
-	
-	//same applies to device2 etc
-	
-	//to get a settings dialog for the device
-	VI.showSettingsWindow(device1);
-	
-	
-	//Shut down devices properly
-	VI.stopDevice(device1);
-	VI.stopDevice(device2);
-*/
-
-
-//////////////////////////////////////   VARS AND DEFS   //////////////////////////////////
-
-
-//STUFF YOU CAN CHANGE
-
-//change for verbose debug info
-static bool verbose = true;
-
-//if you need VI to use multi threaded com
-//#define VI_COM_MULTI_THREADED
-
-//STUFF YOU DON'T CHANGE
-
-//videoInput defines
-#define VI_VERSION	 0.1995
-#define VI_MAX_CAMERAS  20
-#define VI_NUM_TYPES    18 //DON'T TOUCH
-#define VI_NUM_FORMATS  18 //DON'T TOUCH
-
-//defines for setPhyCon - tuner is not as well supported as composite and s-video 
-#define VI_COMPOSITE 0
-#define VI_S_VIDEO   1
-#define VI_TUNER     2
-#define VI_USB       3
-#define VI_1394		 4
-
-//defines for formats
-#define VI_NTSC_M	0
-#define VI_PAL_B	1
-#define VI_PAL_D	2
-#define VI_PAL_G	3
-#define VI_PAL_H	4
-#define VI_PAL_I	5
-#define VI_PAL_M	6
-#define VI_PAL_N	7
-#define VI_PAL_NC	8
-#define VI_SECAM_B	9
-#define VI_SECAM_D	10
-#define VI_SECAM_G	11
-#define VI_SECAM_H	12
-#define VI_SECAM_K	13
-#define VI_SECAM_K1	14
-#define VI_SECAM_L	15
-#define VI_NTSC_M_J	16
-#define VI_NTSC_433	17
-
-
-//allows us to directShow classes here with the includes in the cpp
-struct ICaptureGraphBuilder2;
-struct IGraphBuilder;
-struct IBaseFilter;
-struct IAMCrossbar;
-struct IMediaControl;
-struct ISampleGrabber;
-struct IMediaEventEx;
-struct IAMStreamConfig;
-struct _AMMediaType;
-class SampleGrabberCallback;
-typedef _AMMediaType AM_MEDIA_TYPE;
-
-//keeps track of how many instances of VI are being used
-//don't touch
-static int comInitCount = 0;
-
-
-////////////////////////////////////////   VIDEO DEVICE   ///////////////////////////////////
-
-class videoDevice{
-
-	
-	public:
-		 
-		videoDevice();
-		void setSize(int w, int h);
-		void NukeDownstream(IBaseFilter *pBF);
-		void destroyGraph();
-		~videoDevice();
-		
-		int videoSize;
-		int width;
-		int height;
-		int tryWidth;
-		int tryHeight;
-		
-		ICaptureGraphBuilder2 *pCaptureGraph;	// Capture graph builder object
-		IGraphBuilder *pGraph;					// Graph builder object
-	    IMediaControl *pControl;				// Media control object
-		IBaseFilter *pVideoInputFilter;  		// Video Capture filter
-		IBaseFilter *pGrabberF;
-		IBaseFilter * pDestFilter;
-		IAMStreamConfig *streamConf;
-		ISampleGrabber * pGrabber;    			// Grabs frame
-		AM_MEDIA_TYPE * pAmMediaType;
-		
-		IMediaEventEx * pMediaEvent;
-		
-		GUID videoType;
-		long formatType;
-		
-		SampleGrabberCallback * sgCallback;				
-		
-		bool tryDiffSize;
-		bool useCrossbar;
-		bool readyToCapture;
-		bool sizeSet;
-		bool setupStarted;
-		bool specificFormat;
-		bool autoReconnect;
-		int  nFramesForReconnect;
-		unsigned long nFramesRunning;
-		int  connection;
-		int	 storeConn;
-		int  myID;
-		long requestedFrameTime; //ie fps
-		
-		char 	nDeviceName[255];
-		WCHAR 	wDeviceName[255];
-		
-		unsigned char * pixels;
-		char * pBuffer;
-
-};
-
-
-
-
-//////////////////////////////////////   VIDEO INPUT   /////////////////////////////////////
-
-
-
-class videoInput{
-
-	public:
-		videoInput();
-		~videoInput();
-				
-		//turns off console messages - default is to print messages
-		static void setVerbose(bool _verbose);
-		
-		//Functions in rough order they should be used.
-		static int listDevices(bool silent = false);
-
-		//needs to be called after listDevices - otherwise returns NULL
-		static char * getDeviceName(int deviceID);
-		
-		//choose to use callback based capture - or single threaded
-		void setUseCallback(bool useCallback);	
-		
-		//call before setupDevice
-		//directshow will try and get the closest possible framerate to what is requested
-		void setIdealFramerate(int deviceID, int idealFramerate);
-
-		//some devices will stop delivering frames after a while - this method gives you the option to try and reconnect
-		//to a device if videoInput detects that a device has stopped delivering frames. 
-		//you MUST CALL isFrameNew every app loop for this to have any effect
-		void setAutoReconnectOnFreeze(int deviceNumber, bool doReconnect, int numMissedFramesBeforeReconnect);
-		
-		//Choose one of these four to setup your device
-		bool setupDevice(int deviceID);
-		bool setupDevice(int deviceID, int w, int h);
-
-		//These two are only for capture cards
-		//USB and Firewire cameras souldn't specify connection 
-		bool setupDevice(int deviceID, int connection);	
-		bool setupDevice(int deviceID, int w, int h, int connection); 
-		
-		//If you need to you can set your NTSC/PAL/SECAM
-		//preference here. if it is available it will be used.
-		//see #defines above for available formats - eg VI_NTSC_M or VI_PAL_B
-		//should be called after setupDevice
-		//can be called multiple times
-		bool setFormat(int deviceNumber, int format);	
-				
-		//Tells you when a new frame has arrived - you should call this if you have specified setAutoReconnectOnFreeze to true
-		bool isFrameNew(int deviceID); 
-		
-		bool isDeviceSetup(int deviceID);
-		    
-		//Returns the pixels - flipRedAndBlue toggles RGB/BGR flipping - and you can flip the image too
-		unsigned char * getPixels(int deviceID, bool flipRedAndBlue = true, bool flipImage = false);
-		
-		//Or pass in a buffer for getPixels to fill returns true if successful.
-		bool getPixels(int id, unsigned char * pixels, bool flipRedAndBlue = true, bool flipImage = false);
-		
-		//Launches a pop up settings window
-		//For some reason in GLUT you have to call it twice each time. 
-		void showSettingsWindow(int deviceID);
-		
-		//Manual control over settings thanks..... 
-		//These are experimental for now.
-		bool setVideoSettingFilter(int deviceID, long Property, long lValue, long Flags = NULL, bool useDefaultValue = false);
-		bool setVideoSettingFilterPct(int deviceID, long Property, float pctValue, long Flags = NULL);
-		bool getVideoSettingFilter(int deviceID, long Property, long &min, long &max, long &SteppingDelta, long &currentValue, long &flags, long &defaultValue);
-
-		bool setVideoSettingCamera(int deviceID, long Property, long lValue, long Flags = NULL, bool useDefaultValue = false);
-		bool setVideoSettingCameraPct(int deviceID, long Property, float pctValue, long Flags = NULL);
-		bool getVideoSettingCamera(int deviceID, long Property, long &min, long &max, long &SteppingDelta, long &currentValue, long &flags, long &defaultValue);
-
-		//bool setVideoSettingCam(int deviceID, long Property, long lValue, long Flags = NULL, bool useDefaultValue = false);
-
-		//get width, height and number of pixels
-		int  getWidth(int deviceID);
-		int  getHeight(int deviceID);
-		int  getSize(int deviceID);
-		
-		//completely stops and frees a device
-		void stopDevice(int deviceID);
-		
-		//as above but then sets it up with same settings
-		bool restartDevice(int deviceID);
-		
-		//number of devices available
-		int  devicesFound;
-		
-		long propBrightness;
-		long propContrast;
-		long propHue;
-		long propSaturation;
-		long propSharpness;
-		long propGamma;
-		long propColorEnable;
-		long propWhiteBalance;
-		long propBacklightCompensation;
-		long propGain;
-
-		long propPan;
-		long propTilt;
-		long propRoll;
-		long propZoom;
-		long propExposure;
-		long propIris;
-		long propFocus;
-				
-		
-	private:		
-		void setPhyCon(int deviceID, int conn);                   
-		void setAttemptCaptureSize(int deviceID, int w, int h);   
-		bool setup(int deviceID);
-		void processPixels(unsigned char * src, unsigned char * dst, int width, int height, bool bRGB, bool bFlip);
-		int  start(int deviceID, videoDevice * VD);                   
-		int  getDeviceCount();
-		void getMediaSubtypeAsString(GUID type, char * typeAsString);
-		
-		HRESULT getDevice(IBaseFilter **pSrcFilter, int deviceID, WCHAR * wDeviceName, char * nDeviceName);
-		static HRESULT ShowFilterPropertyPages(IBaseFilter *pFilter);
-		HRESULT SaveGraphFile(IGraphBuilder *pGraph, WCHAR *wszPath);
-		HRESULT routeCrossbar(ICaptureGraphBuilder2 **ppBuild, IBaseFilter **pVidInFilter, int conType, GUID captureMode);
-			
-		//don't touch
-		static bool comInit();
-		static bool comUnInit();
-
-		int  connection;
-		int  callbackSetCount;
-		bool bCallback;
-		
-		GUID CAPTURE_MODE;
-		
-		//Extra video subtypes
-		GUID MEDIASUBTYPE_Y800;
-		GUID MEDIASUBTYPE_Y8;
-		GUID MEDIASUBTYPE_GREY;
-
-		videoDevice * VDList[VI_MAX_CAMERAS];
-		GUID mediaSubtypes[VI_NUM_TYPES];
-		long formatTypes[VI_NUM_FORMATS];
-
-		static void __cdecl basicThread(void * objPtr);
-
-		static char deviceNames[VI_MAX_CAMERAS][255];
-
-}; 
-  
- #endif

3rdparty/lapack/CMakeLists.txt

@@ -1,69 +0,0 @@
-# ----------------------------------------------------------------------------
-#  CMake file for opencv_lapack. See root CMakeLists.txt
-#
-# ----------------------------------------------------------------------------
-if(ANDROID)
-define_3rdparty_module(opencv_lapack)
-else()
-
-project(opencv_lapack)
-
-# List of C++ files:
-
-include_directories(
-	${CMAKE_CURRENT_SOURCE_DIR}
-	"${CMAKE_CURRENT_SOURCE_DIR}/../include"
-    ${CMAKE_CURRENT_BINARY_DIR}
-	)
-
-# The .cpp files:
-file(GLOB lib_srcs *.c)
-file(GLOB lib_hdrs *.h)
-set(lib_ext_hdrs "../include/f2c.h" "../include/cblas.h" "../include/clapack.h")
-
-# ----------------------------------------------------------------------------------
-# 				Define the library target:
-# ----------------------------------------------------------------------------------
-
-set(the_target "opencv_lapack")
-
-add_library(${the_target} STATIC ${lib_srcs} ${lib_hdrs} ${lib_ext_hdrs})
-
-if(PCHSupport_FOUND)
-    set(pch_header ${CMAKE_CURRENT_SOURCE_DIR}/../include/clapack.h)
-    if(${CMAKE_GENERATOR} MATCHES "Visual*" OR ${CMAKE_GENERATOR} MATCHES "Xcode*")
-        if(${CMAKE_GENERATOR} MATCHES "Visual*")
-            set(${the_target}_pch "precomp.c")
-        endif()            
-        add_native_precompiled_header(${the_target} ${pch_header})
-    #elseif(CMAKE_COMPILER_IS_GNUCXX AND ${CMAKE_GENERATOR} MATCHES ".*Makefiles")
-    #    add_precompiled_header(${the_target} ${pch_header})
-    endif()
-endif()
-
-if(MSVC)
-    set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} /W3")
-endif()
-
-if(UNIX)
-  if(CMAKE_COMPILER_IS_GNUCXX OR CV_ICC)
-     set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -fPIC")
-  endif()
-endif()
-
-if(CMAKE_COMPILER_IS_GNUCXX)
-    set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Wno-parentheses -Wno-uninitialized -Wno-implicit-function-declaration -Wno-unused")
-endif()
-
-set_target_properties(${the_target}
-	PROPERTIES OUTPUT_NAME "${the_target}"
-	DEBUG_POSTFIX "${OPENCV_DEBUG_POSTFIX}"
-	ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/3rdparty/lib
-	)
-    
-if(NOT BUILD_SHARED_LIBS)
-    install(TARGETS ${the_target}
-	    ARCHIVE DESTINATION share/opencv/3rdparty/lib COMPONENT main)
-endif()
-    
-endif() #android

3rdparty/lapack/COPYING

@@ -1,36 +0,0 @@
-Copyright (c) 1992-2008 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. 
-

3rdparty/lapack/dasum.c

@@ -1,101 +0,0 @@
-/* dasum.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-doublereal dasum_(integer *n, doublereal *dx, integer *incx)
-{
-    /* System generated locals */
-    integer i__1, i__2;
-    doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6;
-
-    /* Local variables */
-    integer i__, m, mp1;
-    doublereal dtemp;
-    integer nincx;
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*     takes the sum of the absolute values. */
-/*     jack dongarra, linpack, 3/11/78. */
-/*     modified 3/93 to return if incx .le. 0. */
-/*     modified 12/3/93, array(1) declarations changed to array(*) */
-
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-    /* Parameter adjustments */
-    --dx;
-
-    /* Function Body */
-    ret_val = 0.;
-    dtemp = 0.;
-    if (*n <= 0 || *incx <= 0) {
-	return ret_val;
-    }
-    if (*incx == 1) {
-	goto L20;
-    }
-
-/*        code for increment not equal to 1 */
-
-    nincx = *n * *incx;
-    i__1 = nincx;
-    i__2 = *incx;
-    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
-	dtemp += (d__1 = dx[i__], abs(d__1));
-/* L10: */
-    }
-    ret_val = dtemp;
-    return ret_val;
-
-/*        code for increment equal to 1 */
-
-
-/*        clean-up loop */
-
-L20:
-    m = *n % 6;
-    if (m == 0) {
-	goto L40;
-    }
-    i__2 = m;
-    for (i__ = 1; i__ <= i__2; ++i__) {
-	dtemp += (d__1 = dx[i__], abs(d__1));
-/* L30: */
-    }
-    if (*n < 6) {
-	goto L60;
-    }
-L40:
-    mp1 = m + 1;
-    i__2 = *n;
-    for (i__ = mp1; i__ <= i__2; i__ += 6) {
-	dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], 
-		abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ 
-		+ 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = 
-		dx[i__ + 5], abs(d__6));
-/* L50: */
-    }
-L60:
-    ret_val = dtemp;
-    return ret_val;
-} /* dasum_ */

3rdparty/lapack/daxpy.c

@@ -1,107 +0,0 @@
-/* daxpy.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, 
-	integer *incx, doublereal *dy, integer *incy)
-{
-    /* System generated locals */
-    integer i__1;
-
-    /* Local variables */
-    integer i__, m, ix, iy, mp1;
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*     constant times a vector plus a vector. */
-/*     uses unrolled loops for increments equal to one. */
-/*     jack dongarra, linpack, 3/11/78. */
-/*     modified 12/3/93, array(1) declarations changed to array(*) */
-
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-    /* Parameter adjustments */
-    --dy;
-    --dx;
-
-    /* Function Body */
-    if (*n <= 0) {
-	return 0;
-    }
-    if (*da == 0.) {
-	return 0;
-    }
-    if (*incx == 1 && *incy == 1) {
-	goto L20;
-    }
-
-/*        code for unequal increments or equal increments */
-/*          not equal to 1 */
-
-    ix = 1;
-    iy = 1;
-    if (*incx < 0) {
-	ix = (-(*n) + 1) * *incx + 1;
-    }
-    if (*incy < 0) {
-	iy = (-(*n) + 1) * *incy + 1;
-    }
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dy[iy] += *da * dx[ix];
-	ix += *incx;
-	iy += *incy;
-/* L10: */
-    }
-    return 0;
-
-/*        code for both increments equal to 1 */
-
-
-/*        clean-up loop */
-
-L20:
-    m = *n % 4;
-    if (m == 0) {
-	goto L40;
-    }
-    i__1 = m;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dy[i__] += *da * dx[i__];
-/* L30: */
-    }
-    if (*n < 4) {
-	return 0;
-    }
-L40:
-    mp1 = m + 1;
-    i__1 = *n;
-    for (i__ = mp1; i__ <= i__1; i__ += 4) {
-	dy[i__] += *da * dx[i__];
-	dy[i__ + 1] += *da * dx[i__ + 1];
-	dy[i__ + 2] += *da * dx[i__ + 2];
-	dy[i__ + 3] += *da * dx[i__ + 3];
-/* L50: */
-    }
-    return 0;
-} /* daxpy_ */

3rdparty/lapack/dbdsdc.c

@@ -1,514 +0,0 @@
-/* dbdsdc.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__9 = 9;
-static integer c__0 = 0;
-static doublereal c_b15 = 1.;
-static integer c__1 = 1;
-static doublereal c_b29 = 0.;
-
-/* Subroutine */ int dbdsdc_(char *uplo, char *compq, integer *n, doublereal *
-	d__, doublereal *e, doublereal *u, integer *ldu, doublereal *vt, 
-	integer *ldvt, doublereal *q, integer *iq, doublereal *work, integer *
-	iwork, integer *info)
-{
-    /* System generated locals */
-    integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double d_sign(doublereal *, doublereal *), log(doublereal);
-
-    /* Local variables */
-    integer i__, j, k;
-    doublereal p, r__;
-    integer z__, ic, ii, kk;
-    doublereal cs;
-    integer is, iu;
-    doublereal sn;
-    integer nm1;
-    doublereal eps;
-    integer ivt, difl, difr, ierr, perm, mlvl, sqre;
-    extern logical lsame_(char *, char *);
-    extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, 
-	    integer *, doublereal *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *
-, doublereal *, integer *), dswap_(integer *, doublereal *, 
-	    integer *, doublereal *, integer *);
-    integer poles, iuplo, nsize, start;
-    extern /* Subroutine */ int dlasd0_(integer *, integer *, doublereal *, 
-	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
-	    integer *, integer *, doublereal *, integer *);
-    extern doublereal dlamch_(char *);
-    extern /* Subroutine */ int dlasda_(integer *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, doublereal *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
-	     doublereal *, integer *, integer *, integer *, integer *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, integer *, 
-	     integer *), dlascl_(char *, integer *, integer *, doublereal *, 
-	    doublereal *, integer *, integer *, doublereal *, integer *, 
-	    integer *), dlasdq_(char *, integer *, integer *, integer 
-	    *, integer *, integer *, doublereal *, doublereal *, doublereal *, 
-	     integer *, doublereal *, integer *, doublereal *, integer *, 
-	    doublereal *, integer *), dlaset_(char *, integer *, 
-	    integer *, doublereal *, doublereal *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *, 
-	    doublereal *, doublereal *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    extern /* Subroutine */ int xerbla_(char *, integer *);
-    integer givcol;
-    extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
-    integer icompq;
-    doublereal orgnrm;
-    integer givnum, givptr, qstart, smlsiz, wstart, smlszp;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DBDSDC computes the singular value decomposition (SVD) of a real */
-/*  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT, */
-/*  using a divide and conquer method, where S is a diagonal matrix */
-/*  with non-negative diagonal elements (the singular values of B), and */
-/*  U and VT are orthogonal matrices of left and right singular vectors, */
-/*  respectively. DBDSDC can be used to compute all singular values, */
-/*  and optionally, singular vectors or singular vectors in compact form. */
-
-/*  This code makes very mild assumptions about floating point */
-/*  arithmetic. It will work on machines with a guard digit in */
-/*  add/subtract, or on those binary machines without guard digits */
-/*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
-/*  It could conceivably fail on hexadecimal or decimal machines */
-/*  without guard digits, but we know of none.  See DLASD3 for details. */
-
-/*  The code currently calls DLASDQ if singular values only are desired. */
-/*  However, it can be slightly modified to compute singular values */
-/*  using the divide and conquer method. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  UPLO    (input) CHARACTER*1 */
-/*          = 'U':  B is upper bidiagonal. */
-/*          = 'L':  B is lower bidiagonal. */
-
-/*  COMPQ   (input) CHARACTER*1 */
-/*          Specifies whether singular vectors are to be computed */
-/*          as follows: */
-/*          = 'N':  Compute singular values only; */
-/*          = 'P':  Compute singular values and compute singular */
-/*                  vectors in compact form; */
-/*          = 'I':  Compute singular values and singular vectors. */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix B.  N >= 0. */
-
-/*  D       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the n diagonal elements of the bidiagonal matrix B. */
-/*          On exit, if INFO=0, the singular values of B. */
-
-/*  E       (input/output) DOUBLE PRECISION array, dimension (N-1) */
-/*          On entry, the elements of E contain the offdiagonal */
-/*          elements of the bidiagonal matrix whose SVD is desired. */
-/*          On exit, E has been destroyed. */
-
-/*  U       (output) DOUBLE PRECISION array, dimension (LDU,N) */
-/*          If  COMPQ = 'I', then: */
-/*             On exit, if INFO = 0, U contains the left singular vectors */
-/*             of the bidiagonal matrix. */
-/*          For other values of COMPQ, U is not referenced. */
-
-/*  LDU     (input) INTEGER */
-/*          The leading dimension of the array U.  LDU >= 1. */
-/*          If singular vectors are desired, then LDU >= max( 1, N ). */
-
-/*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N) */
-/*          If  COMPQ = 'I', then: */
-/*             On exit, if INFO = 0, VT' contains the right singular */
-/*             vectors of the bidiagonal matrix. */
-/*          For other values of COMPQ, VT is not referenced. */
-
-/*  LDVT    (input) INTEGER */
-/*          The leading dimension of the array VT.  LDVT >= 1. */
-/*          If singular vectors are desired, then LDVT >= max( 1, N ). */
-
-/*  Q       (output) DOUBLE PRECISION array, dimension (LDQ) */
-/*          If  COMPQ = 'P', then: */
-/*             On exit, if INFO = 0, Q and IQ contain the left */
-/*             and right singular vectors in a compact form, */
-/*             requiring O(N log N) space instead of 2*N**2. */
-/*             In particular, Q contains all the DOUBLE PRECISION data in */
-/*             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */
-/*             words of memory, where SMLSIZ is returned by ILAENV and */
-/*             is equal to the maximum size of the subproblems at the */
-/*             bottom of the computation tree (usually about 25). */
-/*          For other values of COMPQ, Q is not referenced. */
-
-/*  IQ      (output) INTEGER array, dimension (LDIQ) */
-/*          If  COMPQ = 'P', then: */
-/*             On exit, if INFO = 0, Q and IQ contain the left */
-/*             and right singular vectors in a compact form, */
-/*             requiring O(N log N) space instead of 2*N**2. */
-/*             In particular, IQ contains all INTEGER data in */
-/*             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */
-/*             words of memory, where SMLSIZ is returned by ILAENV and */
-/*             is equal to the maximum size of the subproblems at the */
-/*             bottom of the computation tree (usually about 25). */
-/*          For other values of COMPQ, IQ is not referenced. */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
-/*          If COMPQ = 'N' then LWORK >= (4 * N). */
-/*          If COMPQ = 'P' then LWORK >= (6 * N). */
-/*          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */
-
-/*  IWORK   (workspace) INTEGER array, dimension (8*N) */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-/*          > 0:  The algorithm failed to compute an singular value. */
-/*                The update process of divide and conquer failed. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Ming Gu and Huan Ren, Computer Science Division, University of */
-/*     California at Berkeley, USA */
-
-/*  ===================================================================== */
-/*  Changed dimension statement in comment describing E from (N) to */
-/*  (N-1).  Sven, 17 Feb 05. */
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    --e;
-    u_dim1 = *ldu;
-    u_offset = 1 + u_dim1;
-    u -= u_offset;
-    vt_dim1 = *ldvt;
-    vt_offset = 1 + vt_dim1;
-    vt -= vt_offset;
-    --q;
-    --iq;
-    --work;
-    --iwork;
-
-    /* Function Body */
-    *info = 0;
-
-    iuplo = 0;
-    if (lsame_(uplo, "U")) {
-	iuplo = 1;
-    }
-    if (lsame_(uplo, "L")) {
-	iuplo = 2;
-    }
-    if (lsame_(compq, "N")) {
-	icompq = 0;
-    } else if (lsame_(compq, "P")) {
-	icompq = 1;
-    } else if (lsame_(compq, "I")) {
-	icompq = 2;
-    } else {
-	icompq = -1;
-    }
-    if (iuplo == 0) {
-	*info = -1;
-    } else if (icompq < 0) {
-	*info = -2;
-    } else if (*n < 0) {
-	*info = -3;
-    } else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
-	*info = -7;
-    } else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
-	*info = -9;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DBDSDC", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0) {
-	return 0;
-    }
-    smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
-    if (*n == 1) {
-	if (icompq == 1) {
-	    q[1] = d_sign(&c_b15, &d__[1]);
-	    q[smlsiz * *n + 1] = 1.;
-	} else if (icompq == 2) {
-	    u[u_dim1 + 1] = d_sign(&c_b15, &d__[1]);
-	    vt[vt_dim1 + 1] = 1.;
-	}
-	d__[1] = abs(d__[1]);
-	return 0;
-    }
-    nm1 = *n - 1;
-
-/*     If matrix lower bidiagonal, rotate to be upper bidiagonal */
-/*     by applying Givens rotations on the left */
-
-    wstart = 1;
-    qstart = 3;
-    if (icompq == 1) {
-	dcopy_(n, &d__[1], &c__1, &q[1], &c__1);
-	i__1 = *n - 1;
-	dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
-    }
-    if (iuplo == 2) {
-	qstart = 5;
-	wstart = (*n << 1) - 1;
-	i__1 = *n - 1;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
-	    d__[i__] = r__;
-	    e[i__] = sn * d__[i__ + 1];
-	    d__[i__ + 1] = cs * d__[i__ + 1];
-	    if (icompq == 1) {
-		q[i__ + (*n << 1)] = cs;
-		q[i__ + *n * 3] = sn;
-	    } else if (icompq == 2) {
-		work[i__] = cs;
-		work[nm1 + i__] = -sn;
-	    }
-/* L10: */
-	}
-    }
-
-/*     If ICOMPQ = 0, use DLASDQ to compute the singular values. */
-
-    if (icompq == 0) {
-	dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
-		vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
-		wstart], info);
-	goto L40;
-    }
-
-/*     If N is smaller than the minimum divide size SMLSIZ, then solve */
-/*     the problem with another solver. */
-
-    if (*n <= smlsiz) {
-	if (icompq == 2) {
-	    dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
-	    dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
-	    dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
-, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
-		    wstart], info);
-	} else if (icompq == 1) {
-	    iu = 1;
-	    ivt = iu + *n;
-	    dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
-	    dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
-	    dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
-		    qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
-		    iu + (qstart - 1) * *n], n, &work[wstart], info);
-	}
-	goto L40;
-    }
-
-    if (icompq == 2) {
-	dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
-	dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
-    }
-
-/*     Scale. */
-
-    orgnrm = dlanst_("M", n, &d__[1], &e[1]);
-    if (orgnrm == 0.) {
-	return 0;
-    }
-    dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
-    dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
-	    ierr);
-
-    eps = dlamch_("Epsilon");
-
-    mlvl = (integer) (log((doublereal) (*n) / (doublereal) (smlsiz + 1)) / 
-	    log(2.)) + 1;
-    smlszp = smlsiz + 1;
-
-    if (icompq == 1) {
-	iu = 1;
-	ivt = smlsiz + 1;
-	difl = ivt + smlszp;
-	difr = difl + mlvl;
-	z__ = difr + (mlvl << 1);
-	ic = z__ + mlvl;
-	is = ic + 1;
-	poles = is + 1;
-	givnum = poles + (mlvl << 1);
-
-	k = 1;
-	givptr = 2;
-	perm = 3;
-	givcol = perm + mlvl;
-    }
-
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	if ((d__1 = d__[i__], abs(d__1)) < eps) {
-	    d__[i__] = d_sign(&eps, &d__[i__]);
-	}
-/* L20: */
-    }
-
-    start = 1;
-    sqre = 0;
-
-    i__1 = nm1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
-
-/*        Subproblem found. First determine its size and then */
-/*        apply divide and conquer on it. */
-
-	    if (i__ < nm1) {
-
-/*        A subproblem with E(I) small for I < NM1. */
-
-		nsize = i__ - start + 1;
-	    } else if ((d__1 = e[i__], abs(d__1)) >= eps) {
-
-/*        A subproblem with E(NM1) not too small but I = NM1. */
-
-		nsize = *n - start + 1;
-	    } else {
-
-/*        A subproblem with E(NM1) small. This implies an */
-/*        1-by-1 subproblem at D(N). Solve this 1-by-1 problem */
-/*        first. */
-
-		nsize = i__ - start + 1;
-		if (icompq == 2) {
-		    u[*n + *n * u_dim1] = d_sign(&c_b15, &d__[*n]);
-		    vt[*n + *n * vt_dim1] = 1.;
-		} else if (icompq == 1) {
-		    q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]);
-		    q[*n + (smlsiz + qstart - 1) * *n] = 1.;
-		}
-		d__[*n] = (d__1 = d__[*n], abs(d__1));
-	    }
-	    if (icompq == 2) {
-		dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start + 
-			start * u_dim1], ldu, &vt[start + start * vt_dim1], 
-			ldvt, &smlsiz, &iwork[1], &work[wstart], info);
-	    } else {
-		dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
-			start], &q[start + (iu + qstart - 2) * *n], n, &q[
-			start + (ivt + qstart - 2) * *n], &iq[start + k * *n], 
-			 &q[start + (difl + qstart - 2) * *n], &q[start + (
-			difr + qstart - 2) * *n], &q[start + (z__ + qstart - 
-			2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
-			start + givptr * *n], &iq[start + givcol * *n], n, &
-			iq[start + perm * *n], &q[start + (givnum + qstart - 
-			2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
-			start + (is + qstart - 2) * *n], &work[wstart], &
-			iwork[1], info);
-		if (*info != 0) {
-		    return 0;
-		}
-	    }
-	    start = i__ + 1;
-	}
-/* L30: */
-    }
-
-/*     Unscale */
-
-    dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
-L40:
-
-/*     Use Selection Sort to minimize swaps of singular vectors */
-
-    i__1 = *n;
-    for (ii = 2; ii <= i__1; ++ii) {
-	i__ = ii - 1;
-	kk = i__;
-	p = d__[i__];
-	i__2 = *n;
-	for (j = ii; j <= i__2; ++j) {
-	    if (d__[j] > p) {
-		kk = j;
-		p = d__[j];
-	    }
-/* L50: */
-	}
-	if (kk != i__) {
-	    d__[kk] = d__[i__];
-	    d__[i__] = p;
-	    if (icompq == 1) {
-		iq[i__] = kk;
-	    } else if (icompq == 2) {
-		dswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], &
-			c__1);
-		dswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt);
-	    }
-	} else if (icompq == 1) {
-	    iq[i__] = i__;
-	}
-/* L60: */
-    }
-
-/*     If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
-
-    if (icompq == 1) {
-	if (iuplo == 1) {
-	    iq[*n] = 1;
-	} else {
-	    iq[*n] = 0;
-	}
-    }
-
-/*     If B is lower bidiagonal, update U by those Givens rotations */
-/*     which rotated B to be upper bidiagonal */
-
-    if (iuplo == 2 && icompq == 2) {
-	dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
-    }
-
-    return 0;
-
-/*     End of DBDSDC */
-
-} /* dbdsdc_ */

3rdparty/lapack/dbdsqr.c

@@ -1,918 +0,0 @@
-/* dbdsqr.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static doublereal c_b15 = -.125;
-static integer c__1 = 1;
-static doublereal c_b49 = 1.;
-static doublereal c_b72 = -1.;
-
-/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
-	nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt, 
-	integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *
-	ldc, doublereal *work, integer *info)
-{
-    /* System generated locals */
-    integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, 
-	    i__2;
-    doublereal d__1, d__2, d__3, d__4;
-
-    /* Builtin functions */
-    double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
-	    doublereal *, doublereal *);
-
-    /* Local variables */
-    doublereal f, g, h__;
-    integer i__, j, m;
-    doublereal r__, cs;
-    integer ll;
-    doublereal sn, mu;
-    integer nm1, nm12, nm13, lll;
-    doublereal eps, sll, tol, abse;
-    integer idir;
-    doublereal abss;
-    integer oldm;
-    doublereal cosl;
-    integer isub, iter;
-    doublereal unfl, sinl, cosr, smin, smax, sinr;
-    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *), dlas2_(
-	    doublereal *, doublereal *, doublereal *, doublereal *, 
-	    doublereal *), dscal_(integer *, doublereal *, doublereal *, 
-	    integer *);
-    extern logical lsame_(char *, char *);
-    doublereal oldcs;
-    extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, 
-	    integer *, doublereal *, doublereal *, doublereal *, integer *);
-    integer oldll;
-    doublereal shift, sigmn, oldsn;
-    extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *);
-    integer maxit;
-    doublereal sminl, sigmx;
-    logical lower;
-    extern /* Subroutine */ int dlasq1_(integer *, doublereal *, doublereal *, 
-	     doublereal *, integer *), dlasv2_(doublereal *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *);
-    extern doublereal dlamch_(char *);
-    extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *), xerbla_(char *, 
-	    integer *);
-    doublereal sminoa, thresh;
-    logical rotate;
-    doublereal tolmul;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     January 2007 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DBDSQR computes the singular values and, optionally, the right and/or */
-/*  left singular vectors from the singular value decomposition (SVD) of */
-/*  a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */
-/*  zero-shift QR algorithm.  The SVD of B has the form */
-
-/*     B = Q * S * P**T */
-
-/*  where S is the diagonal matrix of singular values, Q is an orthogonal */
-/*  matrix of left singular vectors, and P is an orthogonal matrix of */
-/*  right singular vectors.  If left singular vectors are requested, this */
-/*  subroutine actually returns U*Q instead of Q, and, if right singular */
-/*  vectors are requested, this subroutine returns P**T*VT instead of */
-/*  P**T, for given real input matrices U and VT.  When U and VT are the */
-/*  orthogonal matrices that reduce a general matrix A to bidiagonal */
-/*  form:  A = U*B*VT, as computed by DGEBRD, then */
-
-/*     A = (U*Q) * S * (P**T*VT) */
-
-/*  is the SVD of A.  Optionally, the subroutine may also compute Q**T*C */
-/*  for a given real input matrix C. */
-
-/*  See "Computing  Small Singular Values of Bidiagonal Matrices With */
-/*  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
-/*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
-/*  no. 5, pp. 873-912, Sept 1990) and */
-/*  "Accurate singular values and differential qd algorithms," by */
-/*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
-/*  Department, University of California at Berkeley, July 1992 */
-/*  for a detailed description of the algorithm. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  UPLO    (input) CHARACTER*1 */
-/*          = 'U':  B is upper bidiagonal; */
-/*          = 'L':  B is lower bidiagonal. */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix B.  N >= 0. */
-
-/*  NCVT    (input) INTEGER */
-/*          The number of columns of the matrix VT. NCVT >= 0. */
-
-/*  NRU     (input) INTEGER */
-/*          The number of rows of the matrix U. NRU >= 0. */
-
-/*  NCC     (input) INTEGER */
-/*          The number of columns of the matrix C. NCC >= 0. */
-
-/*  D       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the n diagonal elements of the bidiagonal matrix B. */
-/*          On exit, if INFO=0, the singular values of B in decreasing */
-/*          order. */
-
-/*  E       (input/output) DOUBLE PRECISION array, dimension (N-1) */
-/*          On entry, the N-1 offdiagonal elements of the bidiagonal */
-/*          matrix B. */
-/*          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
-/*          will contain the diagonal and superdiagonal elements of a */
-/*          bidiagonal matrix orthogonally equivalent to the one given */
-/*          as input. */
-
-/*  VT      (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */
-/*          On entry, an N-by-NCVT matrix VT. */
-/*          On exit, VT is overwritten by P**T * VT. */
-/*          Not referenced if NCVT = 0. */
-
-/*  LDVT    (input) INTEGER */
-/*          The leading dimension of the array VT. */
-/*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
-
-/*  U       (input/output) DOUBLE PRECISION array, dimension (LDU, N) */
-/*          On entry, an NRU-by-N matrix U. */
-/*          On exit, U is overwritten by U * Q. */
-/*          Not referenced if NRU = 0. */
-
-/*  LDU     (input) INTEGER */
-/*          The leading dimension of the array U.  LDU >= max(1,NRU). */
-
-/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */
-/*          On entry, an N-by-NCC matrix C. */
-/*          On exit, C is overwritten by Q**T * C. */
-/*          Not referenced if NCC = 0. */
-
-/*  LDC     (input) INTEGER */
-/*          The leading dimension of the array C. */
-/*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N) */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  If INFO = -i, the i-th argument had an illegal value */
-/*          > 0: */
-/*             if NCVT = NRU = NCC = 0, */
-/*                = 1, a split was marked by a positive value in E */
-/*                = 2, current block of Z not diagonalized after 30*N */
-/*                     iterations (in inner while loop) */
-/*                = 3, termination criterion of outer while loop not met */
-/*                     (program created more than N unreduced blocks) */
-/*             else NCVT = NRU = NCC = 0, */
-/*                   the algorithm did not converge; D and E contain the */
-/*                   elements of a bidiagonal matrix which is orthogonally */
-/*                   similar to the input matrix B;  if INFO = i, i */
-/*                   elements of E have not converged to zero. */
-
-/*  Internal Parameters */
-/*  =================== */
-
-/*  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) */
-/*          TOLMUL controls the convergence criterion of the QR loop. */
-/*          If it is positive, TOLMUL*EPS is the desired relative */
-/*             precision in the computed singular values. */
-/*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
-/*             desired absolute accuracy in the computed singular */
-/*             values (corresponds to relative accuracy */
-/*             abs(TOLMUL*EPS) in the largest singular value. */
-/*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
-/*             between 10 (for fast convergence) and .1/EPS */
-/*             (for there to be some accuracy in the results). */
-/*          Default is to lose at either one eighth or 2 of the */
-/*             available decimal digits in each computed singular value */
-/*             (whichever is smaller). */
-
-/*  MAXITR  INTEGER, default = 6 */
-/*          MAXITR controls the maximum number of passes of the */
-/*          algorithm through its inner loop. The algorithms stops */
-/*          (and so fails to converge) if the number of passes */
-/*          through the inner loop exceeds MAXITR*N**2. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    --e;
-    vt_dim1 = *ldvt;
-    vt_offset = 1 + vt_dim1;
-    vt -= vt_offset;
-    u_dim1 = *ldu;
-    u_offset = 1 + u_dim1;
-    u -= u_offset;
-    c_dim1 = *ldc;
-    c_offset = 1 + c_dim1;
-    c__ -= c_offset;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-    lower = lsame_(uplo, "L");
-    if (! lsame_(uplo, "U") && ! lower) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*ncvt < 0) {
-	*info = -3;
-    } else if (*nru < 0) {
-	*info = -4;
-    } else if (*ncc < 0) {
-	*info = -5;
-    } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
-	*info = -9;
-    } else if (*ldu < max(1,*nru)) {
-	*info = -11;
-    } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
-	*info = -13;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DBDSQR", &i__1);
-	return 0;
-    }
-    if (*n == 0) {
-	return 0;
-    }
-    if (*n == 1) {
-	goto L160;
-    }
-
-/*     ROTATE is true if any singular vectors desired, false otherwise */
-
-    rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
-
-/*     If no singular vectors desired, use qd algorithm */
-
-    if (! rotate) {
-	dlasq1_(n, &d__[1], &e[1], &work[1], info);
-	return 0;
-    }
-
-    nm1 = *n - 1;
-    nm12 = nm1 + nm1;
-    nm13 = nm12 + nm1;
-    idir = 0;
-
-/*     Get machine constants */
-
-    eps = dlamch_("Epsilon");
-    unfl = dlamch_("Safe minimum");
-
-/*     If matrix lower bidiagonal, rotate to be upper bidiagonal */
-/*     by applying Givens rotations on the left */
-
-    if (lower) {
-	i__1 = *n - 1;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
-	    d__[i__] = r__;
-	    e[i__] = sn * d__[i__ + 1];
-	    d__[i__ + 1] = cs * d__[i__ + 1];
-	    work[i__] = cs;
-	    work[nm1 + i__] = sn;
-/* L10: */
-	}
-
-/*        Update singular vectors if desired */
-
-	if (*nru > 0) {
-	    dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset], 
-		    ldu);
-	}
-	if (*ncc > 0) {
-	    dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset], 
-		     ldc);
-	}
-    }
-
-/*     Compute singular values to relative accuracy TOL */
-/*     (By setting TOL to be negative, algorithm will compute */
-/*     singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
-
-/* Computing MAX */
-/* Computing MIN */
-    d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
-    d__1 = 10., d__2 = min(d__3,d__4);
-    tolmul = max(d__1,d__2);
-    tol = tolmul * eps;
-
-/*     Compute approximate maximum, minimum singular values */
-
-    smax = 0.;
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-/* Computing MAX */
-	d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
-	smax = max(d__2,d__3);
-/* L20: */
-    }
-    i__1 = *n - 1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-/* Computing MAX */
-	d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
-	smax = max(d__2,d__3);
-/* L30: */
-    }
-    sminl = 0.;
-    if (tol >= 0.) {
-
-/*        Relative accuracy desired */
-
-	sminoa = abs(d__[1]);
-	if (sminoa == 0.) {
-	    goto L50;
-	}
-	mu = sminoa;
-	i__1 = *n;
-	for (i__ = 2; i__ <= i__1; ++i__) {
-	    mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
-		    , abs(d__1))));
-	    sminoa = min(sminoa,mu);
-	    if (sminoa == 0.) {
-		goto L50;
-	    }
-/* L40: */
-	}
-L50:
-	sminoa /= sqrt((doublereal) (*n));
-/* Computing MAX */
-	d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
-	thresh = max(d__1,d__2);
-    } else {
-
-/*        Absolute accuracy desired */
-
-/* Computing MAX */
-	d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
-	thresh = max(d__1,d__2);
-    }
-
-/*     Prepare for main iteration loop for the singular values */
-/*     (MAXIT is the maximum number of passes through the inner */
-/*     loop permitted before nonconvergence signalled.) */
-
-    maxit = *n * 6 * *n;
-    iter = 0;
-    oldll = -1;
-    oldm = -1;
-
-/*     M points to last element of unconverged part of matrix */
-
-    m = *n;
-
-/*     Begin main iteration loop */
-
-L60:
-
-/*     Check for convergence or exceeding iteration count */
-
-    if (m <= 1) {
-	goto L160;
-    }
-    if (iter > maxit) {
-	goto L200;
-    }
-
-/*     Find diagonal block of matrix to work on */
-
-    if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
-	d__[m] = 0.;
-    }
-    smax = (d__1 = d__[m], abs(d__1));
-    smin = smax;
-    i__1 = m - 1;
-    for (lll = 1; lll <= i__1; ++lll) {
-	ll = m - lll;
-	abss = (d__1 = d__[ll], abs(d__1));
-	abse = (d__1 = e[ll], abs(d__1));
-	if (tol < 0. && abss <= thresh) {
-	    d__[ll] = 0.;
-	}
-	if (abse <= thresh) {
-	    goto L80;
-	}
-	smin = min(smin,abss);
-/* Computing MAX */
-	d__1 = max(smax,abss);
-	smax = max(d__1,abse);
-/* L70: */
-    }
-    ll = 0;
-    goto L90;
-L80:
-    e[ll] = 0.;
-
-/*     Matrix splits since E(LL) = 0 */
-
-    if (ll == m - 1) {
-
-/*        Convergence of bottom singular value, return to top of loop */
-
-	--m;
-	goto L60;
-    }
-L90:
-    ++ll;
-
-/*     E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
-
-    if (ll == m - 1) {
-
-/*        2 by 2 block, handle separately */
-
-	dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, 
-		 &sinl, &cosl);
-	d__[m - 1] = sigmx;
-	e[m - 1] = 0.;
-	d__[m] = sigmn;
-
-/*        Compute singular vectors, if desired */
-
-	if (*ncvt > 0) {
-	    drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
-		    cosr, &sinr);
-	}
-	if (*nru > 0) {
-	    drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
-		    c__1, &cosl, &sinl);
-	}
-	if (*ncc > 0) {
-	    drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
-		    cosl, &sinl);
-	}
-	m += -2;
-	goto L60;
-    }
-
-/*     If working on new submatrix, choose shift direction */
-/*     (from larger end diagonal element towards smaller) */
-
-    if (ll > oldm || m < oldll) {
-	if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
-
-/*           Chase bulge from top (big end) to bottom (small end) */
-
-	    idir = 1;
-	} else {
-
-/*           Chase bulge from bottom (big end) to top (small end) */
-
-	    idir = 2;
-	}
-    }
-
-/*     Apply convergence tests */
-
-    if (idir == 1) {
-
-/*        Run convergence test in forward direction */
-/*        First apply standard test to bottom of matrix */
-
-	if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs(
-		d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) 
-		{
-	    e[m - 1] = 0.;
-	    goto L60;
-	}
-
-	if (tol >= 0.) {
-
-/*           If relative accuracy desired, */
-/*           apply convergence criterion forward */
-
-	    mu = (d__1 = d__[ll], abs(d__1));
-	    sminl = mu;
-	    i__1 = m - 1;
-	    for (lll = ll; lll <= i__1; ++lll) {
-		if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
-		    e[lll] = 0.;
-		    goto L60;
-		}
-		mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
-			lll], abs(d__1))));
-		sminl = min(sminl,mu);
-/* L100: */
-	    }
-	}
-
-    } else {
-
-/*        Run convergence test in backward direction */
-/*        First apply standard test to top of matrix */
-
-	if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
-		) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
-	    e[ll] = 0.;
-	    goto L60;
-	}
-
-	if (tol >= 0.) {
-
-/*           If relative accuracy desired, */
-/*           apply convergence criterion backward */
-
-	    mu = (d__1 = d__[m], abs(d__1));
-	    sminl = mu;
-	    i__1 = ll;
-	    for (lll = m - 1; lll >= i__1; --lll) {
-		if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
-		    e[lll] = 0.;
-		    goto L60;
-		}
-		mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
-			, abs(d__1))));
-		sminl = min(sminl,mu);
-/* L110: */
-	    }
-	}
-    }
-    oldll = ll;
-    oldm = m;
-
-/*     Compute shift.  First, test if shifting would ruin relative */
-/*     accuracy, and if so set the shift to zero. */
-
-/* Computing MAX */
-    d__1 = eps, d__2 = tol * .01;
-    if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
-
-/*        Use a zero shift to avoid loss of relative accuracy */
-
-	shift = 0.;
-    } else {
-
-/*        Compute the shift from 2-by-2 block at end of matrix */
-
-	if (idir == 1) {
-	    sll = (d__1 = d__[ll], abs(d__1));
-	    dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
-	} else {
-	    sll = (d__1 = d__[m], abs(d__1));
-	    dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
-	}
-
-/*        Test if shift negligible, and if so set to zero */
-
-	if (sll > 0.) {
-/* Computing 2nd power */
-	    d__1 = shift / sll;
-	    if (d__1 * d__1 < eps) {
-		shift = 0.;
-	    }
-	}
-    }
-
-/*     Increment iteration count */
-
-    iter = iter + m - ll;
-
-/*     If SHIFT = 0, do simplified QR iteration */
-
-    if (shift == 0.) {
-	if (idir == 1) {
-
-/*           Chase bulge from top to bottom */
-/*           Save cosines and sines for later singular vector updates */
-
-	    cs = 1.;
-	    oldcs = 1.;
-	    i__1 = m - 1;
-	    for (i__ = ll; i__ <= i__1; ++i__) {
-		d__1 = d__[i__] * cs;
-		dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
-		if (i__ > ll) {
-		    e[i__ - 1] = oldsn * r__;
-		}
-		d__1 = oldcs * r__;
-		d__2 = d__[i__ + 1] * sn;
-		dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
-		work[i__ - ll + 1] = cs;
-		work[i__ - ll + 1 + nm1] = sn;
-		work[i__ - ll + 1 + nm12] = oldcs;
-		work[i__ - ll + 1 + nm13] = oldsn;
-/* L120: */
-	    }
-	    h__ = d__[m] * cs;
-	    d__[m] = h__ * oldcs;
-	    e[m - 1] = h__ * oldsn;
-
-/*           Update singular vectors */
-
-	    if (*ncvt > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
-			ll + vt_dim1], ldvt);
-	    }
-	    if (*nru > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 
-			+ 1], &u[ll * u_dim1 + 1], ldu);
-	    }
-	    if (*ncc > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 
-			+ 1], &c__[ll + c_dim1], ldc);
-	    }
-
-/*           Test convergence */
-
-	    if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
-		e[m - 1] = 0.;
-	    }
-
-	} else {
-
-/*           Chase bulge from bottom to top */
-/*           Save cosines and sines for later singular vector updates */
-
-	    cs = 1.;
-	    oldcs = 1.;
-	    i__1 = ll + 1;
-	    for (i__ = m; i__ >= i__1; --i__) {
-		d__1 = d__[i__] * cs;
-		dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
-		if (i__ < m) {
-		    e[i__] = oldsn * r__;
-		}
-		d__1 = oldcs * r__;
-		d__2 = d__[i__ - 1] * sn;
-		dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
-		work[i__ - ll] = cs;
-		work[i__ - ll + nm1] = -sn;
-		work[i__ - ll + nm12] = oldcs;
-		work[i__ - ll + nm13] = -oldsn;
-/* L130: */
-	    }
-	    h__ = d__[ll] * cs;
-	    d__[ll] = h__ * oldcs;
-	    e[ll] = h__ * oldsn;
-
-/*           Update singular vectors */
-
-	    if (*ncvt > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
-			nm13 + 1], &vt[ll + vt_dim1], ldvt);
-	    }
-	    if (*nru > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
-			 u_dim1 + 1], ldu);
-	    }
-	    if (*ncc > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
-			ll + c_dim1], ldc);
-	    }
-
-/*           Test convergence */
-
-	    if ((d__1 = e[ll], abs(d__1)) <= thresh) {
-		e[ll] = 0.;
-	    }
-	}
-    } else {
-
-/*        Use nonzero shift */
-
-	if (idir == 1) {
-
-/*           Chase bulge from top to bottom */
-/*           Save cosines and sines for later singular vector updates */
-
-	    f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
-		    ll]) + shift / d__[ll]);
-	    g = e[ll];
-	    i__1 = m - 1;
-	    for (i__ = ll; i__ <= i__1; ++i__) {
-		dlartg_(&f, &g, &cosr, &sinr, &r__);
-		if (i__ > ll) {
-		    e[i__ - 1] = r__;
-		}
-		f = cosr * d__[i__] + sinr * e[i__];
-		e[i__] = cosr * e[i__] - sinr * d__[i__];
-		g = sinr * d__[i__ + 1];
-		d__[i__ + 1] = cosr * d__[i__ + 1];
-		dlartg_(&f, &g, &cosl, &sinl, &r__);
-		d__[i__] = r__;
-		f = cosl * e[i__] + sinl * d__[i__ + 1];
-		d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
-		if (i__ < m - 1) {
-		    g = sinl * e[i__ + 1];
-		    e[i__ + 1] = cosl * e[i__ + 1];
-		}
-		work[i__ - ll + 1] = cosr;
-		work[i__ - ll + 1 + nm1] = sinr;
-		work[i__ - ll + 1 + nm12] = cosl;
-		work[i__ - ll + 1 + nm13] = sinl;
-/* L140: */
-	    }
-	    e[m - 1] = f;
-
-/*           Update singular vectors */
-
-	    if (*ncvt > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
-			ll + vt_dim1], ldvt);
-	    }
-	    if (*nru > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 
-			+ 1], &u[ll * u_dim1 + 1], ldu);
-	    }
-	    if (*ncc > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 
-			+ 1], &c__[ll + c_dim1], ldc);
-	    }
-
-/*           Test convergence */
-
-	    if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
-		e[m - 1] = 0.;
-	    }
-
-	} else {
-
-/*           Chase bulge from bottom to top */
-/*           Save cosines and sines for later singular vector updates */
-
-	    f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
-		    ) + shift / d__[m]);
-	    g = e[m - 1];
-	    i__1 = ll + 1;
-	    for (i__ = m; i__ >= i__1; --i__) {
-		dlartg_(&f, &g, &cosr, &sinr, &r__);
-		if (i__ < m) {
-		    e[i__] = r__;
-		}
-		f = cosr * d__[i__] + sinr * e[i__ - 1];
-		e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
-		g = sinr * d__[i__ - 1];
-		d__[i__ - 1] = cosr * d__[i__ - 1];
-		dlartg_(&f, &g, &cosl, &sinl, &r__);
-		d__[i__] = r__;
-		f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
-		d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
-		if (i__ > ll + 1) {
-		    g = sinl * e[i__ - 2];
-		    e[i__ - 2] = cosl * e[i__ - 2];
-		}
-		work[i__ - ll] = cosr;
-		work[i__ - ll + nm1] = -sinr;
-		work[i__ - ll + nm12] = cosl;
-		work[i__ - ll + nm13] = -sinl;
-/* L150: */
-	    }
-	    e[ll] = f;
-
-/*           Test convergence */
-
-	    if ((d__1 = e[ll], abs(d__1)) <= thresh) {
-		e[ll] = 0.;
-	    }
-
-/*           Update singular vectors if desired */
-
-	    if (*ncvt > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
-			nm13 + 1], &vt[ll + vt_dim1], ldvt);
-	    }
-	    if (*nru > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
-			 u_dim1 + 1], ldu);
-	    }
-	    if (*ncc > 0) {
-		i__1 = m - ll + 1;
-		dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
-			ll + c_dim1], ldc);
-	    }
-	}
-    }
-
-/*     QR iteration finished, go back and check convergence */
-
-    goto L60;
-
-/*     All singular values converged, so make them positive */
-
-L160:
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	if (d__[i__] < 0.) {
-	    d__[i__] = -d__[i__];
-
-/*           Change sign of singular vectors, if desired */
-
-	    if (*ncvt > 0) {
-		dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
-	    }
-	}
-/* L170: */
-    }
-
-/*     Sort the singular values into decreasing order (insertion sort on */
-/*     singular values, but only one transposition per singular vector) */
-
-    i__1 = *n - 1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-
-/*        Scan for smallest D(I) */
-
-	isub = 1;
-	smin = d__[1];
-	i__2 = *n + 1 - i__;
-	for (j = 2; j <= i__2; ++j) {
-	    if (d__[j] <= smin) {
-		isub = j;
-		smin = d__[j];
-	    }
-/* L180: */
-	}
-	if (isub != *n + 1 - i__) {
-
-/*           Swap singular values and vectors */
-
-	    d__[isub] = d__[*n + 1 - i__];
-	    d__[*n + 1 - i__] = smin;
-	    if (*ncvt > 0) {
-		dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + 
-			vt_dim1], ldvt);
-	    }
-	    if (*nru > 0) {
-		dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * 
-			u_dim1 + 1], &c__1);
-	    }
-	    if (*ncc > 0) {
-		dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + 
-			c_dim1], ldc);
-	    }
-	}
-/* L190: */
-    }
-    goto L220;
-
-/*     Maximum number of iterations exceeded, failure to converge */
-
-L200:
-    *info = 0;
-    i__1 = *n - 1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	if (e[i__] != 0.) {
-	    ++(*info);
-	}
-/* L210: */
-    }
-L220:
-    return 0;
-
-/*     End of DBDSQR */
-
-} /* dbdsqr_ */

3rdparty/lapack/dcopy.c

@@ -1,107 +0,0 @@
-/* dcopy.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, 
-	doublereal *dy, integer *incy)
-{
-    /* System generated locals */
-    integer i__1;
-
-    /* Local variables */
-    integer i__, m, ix, iy, mp1;
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*     copies a vector, x, to a vector, y. */
-/*     uses unrolled loops for increments equal to one. */
-/*     jack dongarra, linpack, 3/11/78. */
-/*     modified 12/3/93, array(1) declarations changed to array(*) */
-
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-    /* Parameter adjustments */
-    --dy;
-    --dx;
-
-    /* Function Body */
-    if (*n <= 0) {
-	return 0;
-    }
-    if (*incx == 1 && *incy == 1) {
-	goto L20;
-    }
-
-/*        code for unequal increments or equal increments */
-/*          not equal to 1 */
-
-    ix = 1;
-    iy = 1;
-    if (*incx < 0) {
-	ix = (-(*n) + 1) * *incx + 1;
-    }
-    if (*incy < 0) {
-	iy = (-(*n) + 1) * *incy + 1;
-    }
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dy[iy] = dx[ix];
-	ix += *incx;
-	iy += *incy;
-/* L10: */
-    }
-    return 0;
-
-/*        code for both increments equal to 1 */
-
-
-/*        clean-up loop */
-
-L20:
-    m = *n % 7;
-    if (m == 0) {
-	goto L40;
-    }
-    i__1 = m;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dy[i__] = dx[i__];
-/* L30: */
-    }
-    if (*n < 7) {
-	return 0;
-    }
-L40:
-    mp1 = m + 1;
-    i__1 = *n;
-    for (i__ = mp1; i__ <= i__1; i__ += 7) {
-	dy[i__] = dx[i__];
-	dy[i__ + 1] = dx[i__ + 1];
-	dy[i__ + 2] = dx[i__ + 2];
-	dy[i__ + 3] = dx[i__ + 3];
-	dy[i__ + 4] = dx[i__ + 4];
-	dy[i__ + 5] = dx[i__ + 5];
-	dy[i__ + 6] = dx[i__ + 6];
-/* L50: */
-    }
-    return 0;
-} /* dcopy_ */

3rdparty/lapack/ddot.c

@@ -1,110 +0,0 @@
-/* ddot.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, 
-	integer *incy)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal ret_val;
-
-    /* Local variables */
-    integer i__, m, ix, iy, mp1;
-    doublereal dtemp;
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*     forms the dot product of two vectors. */
-/*     uses unrolled loops for increments equal to one. */
-/*     jack dongarra, linpack, 3/11/78. */
-/*     modified 12/3/93, array(1) declarations changed to array(*) */
-
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-    /* Parameter adjustments */
-    --dy;
-    --dx;
-
-    /* Function Body */
-    ret_val = 0.;
-    dtemp = 0.;
-    if (*n <= 0) {
-	return ret_val;
-    }
-    if (*incx == 1 && *incy == 1) {
-	goto L20;
-    }
-
-/*        code for unequal increments or equal increments */
-/*          not equal to 1 */
-
-    ix = 1;
-    iy = 1;
-    if (*incx < 0) {
-	ix = (-(*n) + 1) * *incx + 1;
-    }
-    if (*incy < 0) {
-	iy = (-(*n) + 1) * *incy + 1;
-    }
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dtemp += dx[ix] * dy[iy];
-	ix += *incx;
-	iy += *incy;
-/* L10: */
-    }
-    ret_val = dtemp;
-    return ret_val;
-
-/*        code for both increments equal to 1 */
-
-
-/*        clean-up loop */
-
-L20:
-    m = *n % 5;
-    if (m == 0) {
-	goto L40;
-    }
-    i__1 = m;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dtemp += dx[i__] * dy[i__];
-/* L30: */
-    }
-    if (*n < 5) {
-	goto L60;
-    }
-L40:
-    mp1 = m + 1;
-    i__1 = *n;
-    for (i__ = mp1; i__ <= i__1; i__ += 5) {
-	dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[
-		i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + 
-		4] * dy[i__ + 4];
-/* L50: */
-    }
-L60:
-    ret_val = dtemp;
-    return ret_val;
-} /* ddot_ */

3rdparty/lapack/dgebd2.c

@@ -1,304 +0,0 @@
-/* dgebd2.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-
-/* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer *
-	lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
-	taup, doublereal *work, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3;
-
-    /* Local variables */
-    integer i__;
-    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *), dlarfg_(integer *, doublereal *, 
-	    doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGEBD2 reduces a real general m by n matrix A to upper or lower */
-/*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */
-
-/*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows in the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns in the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the m by n general matrix to be reduced. */
-/*          On exit, */
-/*          if m >= n, the diagonal and the first superdiagonal are */
-/*            overwritten with the upper bidiagonal matrix B; the */
-/*            elements below the diagonal, with the array TAUQ, represent */
-/*            the orthogonal matrix Q as a product of elementary */
-/*            reflectors, and the elements above the first superdiagonal, */
-/*            with the array TAUP, represent the orthogonal matrix P as */
-/*            a product of elementary reflectors; */
-/*          if m < n, the diagonal and the first subdiagonal are */
-/*            overwritten with the lower bidiagonal matrix B; the */
-/*            elements below the first subdiagonal, with the array TAUQ, */
-/*            represent the orthogonal matrix Q as a product of */
-/*            elementary reflectors, and the elements above the diagonal, */
-/*            with the array TAUP, represent the orthogonal matrix P as */
-/*            a product of elementary reflectors. */
-/*          See Further Details. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  D       (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The diagonal elements of the bidiagonal matrix B: */
-/*          D(i) = A(i,i). */
-
-/*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
-/*          The off-diagonal elements of the bidiagonal matrix B: */
-/*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
-/*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
-
-/*  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N)) */
-/*          The scalar factors of the elementary reflectors which */
-/*          represent the orthogonal matrix Q. See Further Details. */
-
-/*  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The scalar factors of the elementary reflectors which */
-/*          represent the orthogonal matrix P. See Further Details. */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
-
-/*  INFO    (output) INTEGER */
-/*          = 0: successful exit. */
-/*          < 0: if INFO = -i, the i-th argument had an illegal value. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  The matrices Q and P are represented as products of elementary */
-/*  reflectors: */
-
-/*  If m >= n, */
-
-/*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1) */
-
-/*  Each H(i) and G(i) has the form: */
-
-/*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u' */
-
-/*  where tauq and taup are real scalars, and v and u are real vectors; */
-/*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
-/*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
-/*  tauq is stored in TAUQ(i) and taup in TAUP(i). */
-
-/*  If m < n, */
-
-/*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m) */
-
-/*  Each H(i) and G(i) has the form: */
-
-/*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u' */
-
-/*  where tauq and taup are real scalars, and v and u are real vectors; */
-/*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
-/*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
-/*  tauq is stored in TAUQ(i) and taup in TAUP(i). */
-
-/*  The contents of A on exit are illustrated by the following examples: */
-
-/*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n): */
-
-/*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 ) */
-/*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 ) */
-/*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 ) */
-/*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 ) */
-/*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 ) */
-/*    (  v1  v2  v3  v4  v5 ) */
-
-/*  where d and e denote diagonal and off-diagonal elements of B, vi */
-/*  denotes an element of the vector defining H(i), and ui an element of */
-/*  the vector defining G(i). */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --d__;
-    --e;
-    --tauq;
-    --taup;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*m)) {
-	*info = -4;
-    }
-    if (*info < 0) {
-	i__1 = -(*info);
-	xerbla_("DGEBD2", &i__1);
-	return 0;
-    }
-
-    if (*m >= *n) {
-
-/*        Reduce to upper bidiagonal form */
-
-	i__1 = *n;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-
-/*           Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
-
-	    i__2 = *m - i__ + 1;
-/* Computing MIN */
-	    i__3 = i__ + 1;
-	    dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * 
-		    a_dim1], &c__1, &tauq[i__]);
-	    d__[i__] = a[i__ + i__ * a_dim1];
-	    a[i__ + i__ * a_dim1] = 1.;
-
-/*           Apply H(i) to A(i:m,i+1:n) from the left */
-
-	    if (i__ < *n) {
-		i__2 = *m - i__ + 1;
-		i__3 = *n - i__;
-		dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
-			tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]
-);
-	    }
-	    a[i__ + i__ * a_dim1] = d__[i__];
-
-	    if (i__ < *n) {
-
-/*              Generate elementary reflector G(i) to annihilate */
-/*              A(i,i+2:n) */
-
-		i__2 = *n - i__;
-/* Computing MIN */
-		i__3 = i__ + 2;
-		dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
-			i__3, *n)* a_dim1], lda, &taup[i__]);
-		e[i__] = a[i__ + (i__ + 1) * a_dim1];
-		a[i__ + (i__ + 1) * a_dim1] = 1.;
-
-/*              Apply G(i) to A(i+1:m,i+1:n) from the right */
-
-		i__2 = *m - i__;
-		i__3 = *n - i__;
-		dlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], 
-			lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], 
-			lda, &work[1]);
-		a[i__ + (i__ + 1) * a_dim1] = e[i__];
-	    } else {
-		taup[i__] = 0.;
-	    }
-/* L10: */
-	}
-    } else {
-
-/*        Reduce to lower bidiagonal form */
-
-	i__1 = *m;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-
-/*           Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
-
-	    i__2 = *n - i__ + 1;
-/* Computing MIN */
-	    i__3 = i__ + 1;
-	    dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)* 
-		    a_dim1], lda, &taup[i__]);
-	    d__[i__] = a[i__ + i__ * a_dim1];
-	    a[i__ + i__ * a_dim1] = 1.;
-
-/*           Apply G(i) to A(i+1:m,i:n) from the right */
-
-	    if (i__ < *m) {
-		i__2 = *m - i__;
-		i__3 = *n - i__ + 1;
-		dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
-			taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
-	    }
-	    a[i__ + i__ * a_dim1] = d__[i__];
-
-	    if (i__ < *m) {
-
-/*              Generate elementary reflector H(i) to annihilate */
-/*              A(i+2:m,i) */
-
-		i__2 = *m - i__;
-/* Computing MIN */
-		i__3 = i__ + 2;
-		dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m)+ 
-			i__ * a_dim1], &c__1, &tauq[i__]);
-		e[i__] = a[i__ + 1 + i__ * a_dim1];
-		a[i__ + 1 + i__ * a_dim1] = 1.;
-
-/*              Apply H(i) to A(i+1:m,i+1:n) from the left */
-
-		i__2 = *m - i__;
-		i__3 = *n - i__;
-		dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
-			c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], 
-			lda, &work[1]);
-		a[i__ + 1 + i__ * a_dim1] = e[i__];
-	    } else {
-		tauq[i__] = 0.;
-	    }
-/* L20: */
-	}
-    }
-    return 0;
-
-/*     End of DGEBD2 */
-
-} /* dgebd2_ */

3rdparty/lapack/dgebrd.c

@@ -1,336 +0,0 @@
-/* dgebrd.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c_n1 = -1;
-static integer c__3 = 3;
-static integer c__2 = 2;
-static doublereal c_b21 = -1.;
-static doublereal c_b22 = 1.;
-
-/* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer *
-	lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
-	taup, doublereal *work, integer *lwork, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
-
-    /* Local variables */
-    integer i__, j, nb, nx;
-    doublereal ws;
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *);
-    integer nbmin, iinfo, minmn;
-    extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, doublereal *, doublereal *, 
-	     doublereal *, integer *), dlabrd_(integer *, integer *, integer *
-, doublereal *, integer *, doublereal *, doublereal *, doublereal 
-	    *, doublereal *, doublereal *, integer *, doublereal *, integer *)
-	    , xerbla_(char *, integer *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    integer ldwrkx, ldwrky, lwkopt;
-    logical lquery;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGEBRD reduces a general real M-by-N matrix A to upper or lower */
-/*  bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. */
-
-/*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows in the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns in the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the M-by-N general matrix to be reduced. */
-/*          On exit, */
-/*          if m >= n, the diagonal and the first superdiagonal are */
-/*            overwritten with the upper bidiagonal matrix B; the */
-/*            elements below the diagonal, with the array TAUQ, represent */
-/*            the orthogonal matrix Q as a product of elementary */
-/*            reflectors, and the elements above the first superdiagonal, */
-/*            with the array TAUP, represent the orthogonal matrix P as */
-/*            a product of elementary reflectors; */
-/*          if m < n, the diagonal and the first subdiagonal are */
-/*            overwritten with the lower bidiagonal matrix B; the */
-/*            elements below the first subdiagonal, with the array TAUQ, */
-/*            represent the orthogonal matrix Q as a product of */
-/*            elementary reflectors, and the elements above the diagonal, */
-/*            with the array TAUP, represent the orthogonal matrix P as */
-/*            a product of elementary reflectors. */
-/*          See Further Details. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  D       (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The diagonal elements of the bidiagonal matrix B: */
-/*          D(i) = A(i,i). */
-
-/*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
-/*          The off-diagonal elements of the bidiagonal matrix B: */
-/*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
-/*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
-
-/*  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N)) */
-/*          The scalar factors of the elementary reflectors which */
-/*          represent the orthogonal matrix Q. See Further Details. */
-
-/*  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The scalar factors of the elementary reflectors which */
-/*          represent the orthogonal matrix P. See Further Details. */
-
-/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
-/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
-
-/*  LWORK   (input) INTEGER */
-/*          The length of the array WORK.  LWORK >= max(1,M,N). */
-/*          For optimum performance LWORK >= (M+N)*NB, where NB */
-/*          is the optimal blocksize. */
-
-/*          If LWORK = -1, then a workspace query is assumed; the routine */
-/*          only calculates the optimal size of the WORK array, returns */
-/*          this value as the first entry of the WORK array, and no error */
-/*          message related to LWORK is issued by XERBLA. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  The matrices Q and P are represented as products of elementary */
-/*  reflectors: */
-
-/*  If m >= n, */
-
-/*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1) */
-
-/*  Each H(i) and G(i) has the form: */
-
-/*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u' */
-
-/*  where tauq and taup are real scalars, and v and u are real vectors; */
-/*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
-/*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
-/*  tauq is stored in TAUQ(i) and taup in TAUP(i). */
-
-/*  If m < n, */
-
-/*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m) */
-
-/*  Each H(i) and G(i) has the form: */
-
-/*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u' */
-
-/*  where tauq and taup are real scalars, and v and u are real vectors; */
-/*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
-/*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
-/*  tauq is stored in TAUQ(i) and taup in TAUP(i). */
-
-/*  The contents of A on exit are illustrated by the following examples: */
-
-/*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n): */
-
-/*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 ) */
-/*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 ) */
-/*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 ) */
-/*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 ) */
-/*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 ) */
-/*    (  v1  v2  v3  v4  v5 ) */
-
-/*  where d and e denote diagonal and off-diagonal elements of B, vi */
-/*  denotes an element of the vector defining H(i), and ui an element of */
-/*  the vector defining G(i). */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --d__;
-    --e;
-    --tauq;
-    --taup;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-/* Computing MAX */
-    i__1 = 1, i__2 = ilaenv_(&c__1, "DGEBRD", " ", m, n, &c_n1, &c_n1);
-    nb = max(i__1,i__2);
-    lwkopt = (*m + *n) * nb;
-    work[1] = (doublereal) lwkopt;
-    lquery = *lwork == -1;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*m)) {
-	*info = -4;
-    } else /* if(complicated condition) */ {
-/* Computing MAX */
-	i__1 = max(1,*m);
-	if (*lwork < max(i__1,*n) && ! lquery) {
-	    *info = -10;
-	}
-    }
-    if (*info < 0) {
-	i__1 = -(*info);
-	xerbla_("DGEBRD", &i__1);
-	return 0;
-    } else if (lquery) {
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    minmn = min(*m,*n);
-    if (minmn == 0) {
-	work[1] = 1.;
-	return 0;
-    }
-
-    ws = (doublereal) max(*m,*n);
-    ldwrkx = *m;
-    ldwrky = *n;
-
-    if (nb > 1 && nb < minmn) {
-
-/*        Set the crossover point NX. */
-
-/* Computing MAX */
-	i__1 = nb, i__2 = ilaenv_(&c__3, "DGEBRD", " ", m, n, &c_n1, &c_n1);
-	nx = max(i__1,i__2);
-
-/*        Determine when to switch from blocked to unblocked code. */
-
-	if (nx < minmn) {
-	    ws = (doublereal) ((*m + *n) * nb);
-	    if ((doublereal) (*lwork) < ws) {
-
-/*              Not enough work space for the optimal NB, consider using */
-/*              a smaller block size. */
-
-		nbmin = ilaenv_(&c__2, "DGEBRD", " ", m, n, &c_n1, &c_n1);
-		if (*lwork >= (*m + *n) * nbmin) {
-		    nb = *lwork / (*m + *n);
-		} else {
-		    nb = 1;
-		    nx = minmn;
-		}
-	    }
-	}
-    } else {
-	nx = minmn;
-    }
-
-    i__1 = minmn - nx;
-    i__2 = nb;
-    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
-
-/*        Reduce rows and columns i:i+nb-1 to bidiagonal form and return */
-/*        the matrices X and Y which are needed to update the unreduced */
-/*        part of the matrix */
-
-	i__3 = *m - i__ + 1;
-	i__4 = *n - i__ + 1;
-	dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[
-		i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx 
-		* nb + 1], &ldwrky);
-
-/*        Update the trailing submatrix A(i+nb:m,i+nb:n), using an update */
-/*        of the form  A := A - V*Y' - X*U' */
-
-	i__3 = *m - i__ - nb + 1;
-	i__4 = *n - i__ - nb + 1;
-	dgemm_("No transpose", "Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__ 
-		+ nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], &
-		ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda);
-	i__3 = *m - i__ - nb + 1;
-	i__4 = *n - i__ - nb + 1;
-	dgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &c_b21, &
-		work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, &
-		c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda);
-
-/*        Copy diagonal and off-diagonal elements of B back into A */
-
-	if (*m >= *n) {
-	    i__3 = i__ + nb - 1;
-	    for (j = i__; j <= i__3; ++j) {
-		a[j + j * a_dim1] = d__[j];
-		a[j + (j + 1) * a_dim1] = e[j];
-/* L10: */
-	    }
-	} else {
-	    i__3 = i__ + nb - 1;
-	    for (j = i__; j <= i__3; ++j) {
-		a[j + j * a_dim1] = d__[j];
-		a[j + 1 + j * a_dim1] = e[j];
-/* L20: */
-	    }
-	}
-/* L30: */
-    }
-
-/*     Use unblocked code to reduce the remainder of the matrix */
-
-    i__2 = *m - i__ + 1;
-    i__1 = *n - i__ + 1;
-    dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
-	    tauq[i__], &taup[i__], &work[1], &iinfo);
-    work[1] = ws;
-    return 0;
-
-/*     End of DGEBRD */
-
-} /* dgebrd_ */

3rdparty/lapack/dgelq2.c

@@ -1,157 +0,0 @@
-/* dgelq2.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer *
-	lda, doublereal *tau, doublereal *work, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3;
-
-    /* Local variables */
-    integer i__, k;
-    doublereal aii;
-    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *), dlarfp_(integer *, doublereal *, 
-	    doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGELQ2 computes an LQ factorization of a real m by n matrix A: */
-/*  A = L * Q. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the m by n matrix A. */
-/*          On exit, the elements on and below the diagonal of the array */
-/*          contain the m by min(m,n) lower trapezoidal matrix L (L is */
-/*          lower triangular if m <= n); the elements above the diagonal, */
-/*          with the array TAU, represent the orthogonal matrix Q as a */
-/*          product of elementary reflectors (see Further Details). */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The scalar factors of the elementary reflectors (see Further */
-/*          Details). */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (M) */
-
-/*  INFO    (output) INTEGER */
-/*          = 0: successful exit */
-/*          < 0: if INFO = -i, the i-th argument had an illegal value */
-
-/*  Further Details */
-/*  =============== */
-
-/*  The matrix Q is represented as a product of elementary reflectors */
-
-/*     Q = H(k) . . . H(2) H(1), where k = min(m,n). */
-
-/*  Each H(i) has the form */
-
-/*     H(i) = I - tau * v * v' */
-
-/*  where tau is a real scalar, and v is a real vector with */
-/*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
-/*  and tau in TAU(i). */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input arguments */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --tau;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*m)) {
-	*info = -4;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGELQ2", &i__1);
-	return 0;
-    }
-
-    k = min(*m,*n);
-
-    i__1 = k;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-
-/*        Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
-
-	i__2 = *n - i__ + 1;
-/* Computing MIN */
-	i__3 = i__ + 1;
-	dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)* a_dim1]
-, lda, &tau[i__]);
-	if (i__ < *m) {
-
-/*           Apply H(i) to A(i+1:m,i:n) from the right */
-
-	    aii = a[i__ + i__ * a_dim1];
-	    a[i__ + i__ * a_dim1] = 1.;
-	    i__2 = *m - i__;
-	    i__3 = *n - i__ + 1;
-	    dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
-		    i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
-	    a[i__ + i__ * a_dim1] = aii;
-	}
-/* L10: */
-    }
-    return 0;
-
-/*     End of DGELQ2 */
-
-} /* dgelq2_ */

3rdparty/lapack/dgelqf.c

@@ -1,251 +0,0 @@
-/* dgelqf.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c_n1 = -1;
-static integer c__3 = 3;
-static integer c__2 = 2;
-
-/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer *
-	lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
-
-    /* Local variables */
-    integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
-    extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, 
-	     char *, char *, char *, integer *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal 
-	    *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    integer ldwork, lwkopt;
-    logical lquery;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGELQF computes an LQ factorization of a real M-by-N matrix A: */
-/*  A = L * Q. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the M-by-N matrix A. */
-/*          On exit, the elements on and below the diagonal of the array */
-/*          contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
-/*          lower triangular if m <= n); the elements above the diagonal, */
-/*          with the array TAU, represent the orthogonal matrix Q as a */
-/*          product of elementary reflectors (see Further Details). */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The scalar factors of the elementary reflectors (see Further */
-/*          Details). */
-
-/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
-/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
-
-/*  LWORK   (input) INTEGER */
-/*          The dimension of the array WORK.  LWORK >= max(1,M). */
-/*          For optimum performance LWORK >= M*NB, where NB is the */
-/*          optimal blocksize. */
-
-/*          If LWORK = -1, then a workspace query is assumed; the routine */
-/*          only calculates the optimal size of the WORK array, returns */
-/*          this value as the first entry of the WORK array, and no error */
-/*          message related to LWORK is issued by XERBLA. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
-
-/*  Further Details */
-/*  =============== */
-
-/*  The matrix Q is represented as a product of elementary reflectors */
-
-/*     Q = H(k) . . . H(2) H(1), where k = min(m,n). */
-
-/*  Each H(i) has the form */
-
-/*     H(i) = I - tau * v * v' */
-
-/*  where tau is a real scalar, and v is a real vector with */
-/*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
-/*  and tau in TAU(i). */
-
-/*  ===================================================================== */
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input arguments */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --tau;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-    nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
-    lwkopt = *m * nb;
-    work[1] = (doublereal) lwkopt;
-    lquery = *lwork == -1;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*m)) {
-	*info = -4;
-    } else if (*lwork < max(1,*m) && ! lquery) {
-	*info = -7;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGELQF", &i__1);
-	return 0;
-    } else if (lquery) {
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    k = min(*m,*n);
-    if (k == 0) {
-	work[1] = 1.;
-	return 0;
-    }
-
-    nbmin = 2;
-    nx = 0;
-    iws = *m;
-    if (nb > 1 && nb < k) {
-
-/*        Determine when to cross over from blocked to unblocked code. */
-
-/* Computing MAX */
-	i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1);
-	nx = max(i__1,i__2);
-	if (nx < k) {
-
-/*           Determine if workspace is large enough for blocked code. */
-
-	    ldwork = *m;
-	    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;
-/* Computing MAX */
-		i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, &
-			c_n1);
-		nbmin = max(i__1,i__2);
-	    }
-	}
-    }
-
-    if (nb >= nbmin && nb < k && nx < k) {
-
-/*        Use blocked code initially */
-
-	i__1 = k - nx;
-	i__2 = nb;
-	for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
-/* Computing MIN */
-	    i__3 = k - i__ + 1;
-	    ib = min(i__3,nb);
-
-/*           Compute the LQ factorization of the current block */
-/*           A(i:i+ib-1,i:n) */
-
-	    i__3 = *n - i__ + 1;
-	    dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
-		    1], &iinfo);
-	    if (i__ + ib <= *m) {
-
-/*              Form the triangular factor of the block reflector */
-/*              H = H(i) H(i+1) . . . H(i+ib-1) */
-
-		i__3 = *n - i__ + 1;
-		dlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ * 
-			a_dim1], lda, &tau[i__], &work[1], &ldwork);
-
-/*              Apply H to A(i+ib:m,i:n) from the right */
-
-		i__3 = *m - i__ - ib + 1;
-		i__4 = *n - i__ + 1;
-		dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, 
-			&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
-			ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + 
-			1], &ldwork);
-	    }
-/* L10: */
-	}
-    } else {
-	i__ = 1;
-    }
-
-/*     Use unblocked code to factor the last or only block. */
-
-    if (i__ <= k) {
-	i__2 = *m - i__ + 1;
-	i__1 = *n - i__ + 1;
-	dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
-, &iinfo);
-    }
-
-    work[1] = (doublereal) iws;
-    return 0;
-
-/*     End of DGELQF */
-
-} /* dgelqf_ */

3rdparty/lapack/dgels.c

@@ -1,515 +0,0 @@
-/* dgels.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c_n1 = -1;
-static doublereal c_b33 = 0.;
-static integer c__0 = 0;
-
-/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *
-	nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, 
-	doublereal *work, integer *lwork, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
-
-    /* Local variables */
-    integer i__, j, nb, mn;
-    doublereal anrm, bnrm;
-    integer brow;
-    logical tpsd;
-    integer iascl, ibscl;
-    extern logical lsame_(char *, char *);
-    integer wsize;
-    doublereal rwork[1];
-    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
-    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *);
-    extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *, integer *), 
-	    dlascl_(char *, integer *, integer *, doublereal *, doublereal *, 
-	    integer *, integer *, doublereal *, integer *, integer *),
-	     dgeqrf_(integer *, integer *, doublereal *, integer *, 
-	    doublereal *, doublereal *, integer *, integer *), dlaset_(char *, 
-	     integer *, integer *, doublereal *, doublereal *, doublereal *, 
-	    integer *), xerbla_(char *, integer *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    integer scllen;
-    doublereal bignum;
-    extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
-	    integer *, doublereal *, integer *, integer *), 
-	    dormqr_(char *, char *, integer *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *, integer *, integer *);
-    doublereal smlnum;
-    logical lquery;
-    extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *, integer *, 
-	    integer *);
-
-
-/*  -- LAPACK driver routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGELS solves overdetermined or underdetermined real linear systems */
-/*  involving an M-by-N matrix A, or its transpose, using a QR or LQ */
-/*  factorization of A.  It is assumed that A has full rank. */
-
-/*  The following options are provided: */
-
-/*  1. If TRANS = 'N' and m >= n:  find the least squares solution of */
-/*     an overdetermined system, i.e., solve the least squares problem */
-/*                  minimize || B - A*X ||. */
-
-/*  2. If TRANS = 'N' and m < n:  find the minimum norm solution of */
-/*     an underdetermined system A * X = B. */
-
-/*  3. If TRANS = 'T' and m >= n:  find the minimum norm solution of */
-/*     an undetermined system A**T * X = B. */
-
-/*  4. If TRANS = 'T' and m < n:  find the least squares solution of */
-/*     an overdetermined system, i.e., solve the least squares problem */
-/*                  minimize || B - A**T * X ||. */
-
-/*  Several right hand side vectors b and solution vectors x can be */
-/*  handled in a single call; they are stored as the columns of the */
-/*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
-/*  matrix X. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  TRANS   (input) CHARACTER*1 */
-/*          = 'N': the linear system involves A; */
-/*          = 'T': the linear system involves A**T. */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0. */
-
-/*  NRHS    (input) INTEGER */
-/*          The number of right hand sides, i.e., the number of */
-/*          columns of the matrices B and X. NRHS >=0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the M-by-N matrix A. */
-/*          On exit, */
-/*            if M >= N, A is overwritten by details of its QR */
-/*                       factorization as returned by DGEQRF; */
-/*            if M <  N, A is overwritten by details of its LQ */
-/*                       factorization as returned by DGELQF. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
-/*          On entry, the matrix B of right hand side vectors, stored */
-/*          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
-/*          if TRANS = 'T'. */
-/*          On exit, if INFO = 0, B is overwritten by the solution */
-/*          vectors, stored columnwise: */
-/*          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
-/*          squares solution vectors; the residual sum of squares for the */
-/*          solution in each column is given by the sum of squares of */
-/*          elements N+1 to M in that column; */
-/*          if TRANS = 'N' and m < n, rows 1 to N of B contain the */
-/*          minimum norm solution vectors; */
-/*          if TRANS = 'T' and m >= n, rows 1 to M of B contain the */
-/*          minimum norm solution vectors; */
-/*          if TRANS = 'T' and m < n, rows 1 to M of B contain the */
-/*          least squares solution vectors; the residual sum of squares */
-/*          for the solution in each column is given by the sum of */
-/*          squares of elements M+1 to N in that column. */
-
-/*  LDB     (input) INTEGER */
-/*          The leading dimension of the array B. LDB >= MAX(1,M,N). */
-
-/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
-/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
-
-/*  LWORK   (input) INTEGER */
-/*          The dimension of the array WORK. */
-/*          LWORK >= max( 1, MN + max( MN, NRHS ) ). */
-/*          For optimal performance, */
-/*          LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
-/*          where MN = min(M,N) and NB is the optimum block size. */
-
-/*          If LWORK = -1, then a workspace query is assumed; the routine */
-/*          only calculates the optimal size of the WORK array, returns */
-/*          this value as the first entry of the WORK array, and no error */
-/*          message related to LWORK is issued by XERBLA. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
-/*          > 0:  if INFO =  i, the i-th diagonal element of the */
-/*                triangular factor of A is zero, so that A does not have */
-/*                full rank; the least squares solution could not be */
-/*                computed. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Local Arrays .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input arguments. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-    mn = min(*m,*n);
-    lquery = *lwork == -1;
-    if (! (lsame_(trans, "N") || lsame_(trans, "T"))) {
-	*info = -1;
-    } else if (*m < 0) {
-	*info = -2;
-    } else if (*n < 0) {
-	*info = -3;
-    } else if (*nrhs < 0) {
-	*info = -4;
-    } else if (*lda < max(1,*m)) {
-	*info = -6;
-    } else /* if(complicated condition) */ {
-/* Computing MAX */
-	i__1 = max(1,*m);
-	if (*ldb < max(i__1,*n)) {
-	    *info = -8;
-	} else /* if(complicated condition) */ {
-/* Computing MAX */
-	    i__1 = 1, i__2 = mn + max(mn,*nrhs);
-	    if (*lwork < max(i__1,i__2) && ! lquery) {
-		*info = -10;
-	    }
-	}
-    }
-
-/*     Figure out optimal block size */
-
-    if (*info == 0 || *info == -10) {
-
-	tpsd = TRUE_;
-	if (lsame_(trans, "N")) {
-	    tpsd = FALSE_;
-	}
-
-	if (*m >= *n) {
-	    nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
-	    if (tpsd) {
-/* Computing MAX */
-		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, &
-			c_n1);
-		nb = max(i__1,i__2);
-	    } else {
-/* Computing MAX */
-		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, &
-			c_n1);
-		nb = max(i__1,i__2);
-	    }
-	} else {
-	    nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
-	    if (tpsd) {
-/* Computing MAX */
-		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, &
-			c_n1);
-		nb = max(i__1,i__2);
-	    } else {
-/* Computing MAX */
-		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, &
-			c_n1);
-		nb = max(i__1,i__2);
-	    }
-	}
-
-/* Computing MAX */
-	i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
-	wsize = max(i__1,i__2);
-	work[1] = (doublereal) wsize;
-
-    }
-
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGELS ", &i__1);
-	return 0;
-    } else if (lquery) {
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-/* Computing MIN */
-    i__1 = min(*m,*n);
-    if (min(i__1,*nrhs) == 0) {
-	i__1 = max(*m,*n);
-	dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
-	return 0;
-    }
-
-/*     Get machine parameters */
-
-    smlnum = dlamch_("S") / dlamch_("P");
-    bignum = 1. / smlnum;
-    dlabad_(&smlnum, &bignum);
-
-/*     Scale A, B if max element outside range [SMLNUM,BIGNUM] */
-
-    anrm = dlange_("M", m, n, &a[a_offset], lda, rwork);
-    iascl = 0;
-    if (anrm > 0. && anrm < smlnum) {
-
-/*        Scale matrix norm up to SMLNUM */
-
-	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
-		info);
-	iascl = 1;
-    } else if (anrm > bignum) {
-
-/*        Scale matrix norm down to BIGNUM */
-
-	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
-		info);
-	iascl = 2;
-    } else if (anrm == 0.) {
-
-/*        Matrix all zero. Return zero solution. */
-
-	i__1 = max(*m,*n);
-	dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
-	goto L50;
-    }
-
-    brow = *m;
-    if (tpsd) {
-	brow = *n;
-    }
-    bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
-    ibscl = 0;
-    if (bnrm > 0. && bnrm < smlnum) {
-
-/*        Scale matrix norm up to SMLNUM */
-
-	dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], 
-		ldb, info);
-	ibscl = 1;
-    } else if (bnrm > bignum) {
-
-/*        Scale matrix norm down to BIGNUM */
-
-	dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], 
-		ldb, info);
-	ibscl = 2;
-    }
-
-    if (*m >= *n) {
-
-/*        compute QR factorization of A */
-
-	i__1 = *lwork - mn;
-	dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
-		;
-
-/*        workspace at least N, optimally N*NB */
-
-	if (! tpsd) {
-
-/*           Least-Squares Problem min || A * X - B || */
-
-/*           B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
-
-	    i__1 = *lwork - mn;
-	    dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
-		    1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
-
-/*           workspace at least NRHS, optimally NRHS*NB */
-
-/*           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
-
-	    dtrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
-, lda, &b[b_offset], ldb, info);
-
-	    if (*info > 0) {
-		return 0;
-	    }
-
-	    scllen = *n;
-
-	} else {
-
-/*           Overdetermined system of equations A' * X = B */
-
-/*           B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
-
-	    dtrtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset], 
-		    lda, &b[b_offset], ldb, info);
-
-	    if (*info > 0) {
-		return 0;
-	    }
-
-/*           B(N+1:M,1:NRHS) = ZERO */
-
-	    i__1 = *nrhs;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = *m;
-		for (i__ = *n + 1; i__ <= i__2; ++i__) {
-		    b[i__ + j * b_dim1] = 0.;
-/* L10: */
-		}
-/* L20: */
-	    }
-
-/*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
-
-	    i__1 = *lwork - mn;
-	    dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
-		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
-
-/*           workspace at least NRHS, optimally NRHS*NB */
-
-	    scllen = *m;
-
-	}
-
-    } else {
-
-/*        Compute LQ factorization of A */
-
-	i__1 = *lwork - mn;
-	dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
-		;
-
-/*        workspace at least M, optimally M*NB. */
-
-	if (! tpsd) {
-
-/*           underdetermined system of equations A * X = B */
-
-/*           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
-
-	    dtrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
-, lda, &b[b_offset], ldb, info);
-
-	    if (*info > 0) {
-		return 0;
-	    }
-
-/*           B(M+1:N,1:NRHS) = 0 */
-
-	    i__1 = *nrhs;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = *n;
-		for (i__ = *m + 1; i__ <= i__2; ++i__) {
-		    b[i__ + j * b_dim1] = 0.;
-/* L30: */
-		}
-/* L40: */
-	    }
-
-/*           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
-
-	    i__1 = *lwork - mn;
-	    dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
-		    1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
-
-/*           workspace at least NRHS, optimally NRHS*NB */
-
-	    scllen = *n;
-
-	} else {
-
-/*           overdetermined system min || A' * X - B || */
-
-/*           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
-
-	    i__1 = *lwork - mn;
-	    dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
-		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
-
-/*           workspace at least NRHS, optimally NRHS*NB */
-
-/*           B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
-
-	    dtrtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset], 
-		    lda, &b[b_offset], ldb, info);
-
-	    if (*info > 0) {
-		return 0;
-	    }
-
-	    scllen = *m;
-
-	}
-
-    }
-
-/*     Undo scaling */
-
-    if (iascl == 1) {
-	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
-, ldb, info);
-    } else if (iascl == 2) {
-	dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
-, ldb, info);
-    }
-    if (ibscl == 1) {
-	dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
-, ldb, info);
-    } else if (ibscl == 2) {
-	dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
-, ldb, info);
-    }
-
-L50:
-    work[1] = (doublereal) wsize;
-
-    return 0;
-
-/*     End of DGELS */
-
-} /* dgels_ */

3rdparty/lapack/dgelsd.c

@@ -1,693 +0,0 @@
-/* dgelsd.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__6 = 6;
-static integer c_n1 = -1;
-static integer c__9 = 9;
-static integer c__0 = 0;
-static integer c__1 = 1;
-static doublereal c_b82 = 0.;
-
-/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs, 
-	doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
-	s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, 
-	 integer *iwork, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
-
-    /* Builtin functions */
-    double log(doublereal);
-
-    /* Local variables */
-    integer ie, il, mm;
-    doublereal eps, anrm, bnrm;
-    integer itau, nlvl, iascl, ibscl;
-    doublereal sfmin;
-    integer minmn, maxmn, itaup, itauq, mnthr, nwork;
-    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebrd_(
-	    integer *, integer *, doublereal *, integer *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, integer *, 
-	     integer *);
-    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *);
-    extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *, integer *), 
-	    dlalsd_(char *, integer *, integer *, integer *, doublereal *, 
-	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
-	    doublereal *, integer *, integer *), dlascl_(char *, 
-	    integer *, integer *, doublereal *, doublereal *, integer *, 
-	    integer *, doublereal *, integer *, integer *), dgeqrf_(
-	    integer *, integer *, doublereal *, integer *, doublereal *, 
-	    doublereal *, integer *, integer *), dlacpy_(char *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *, 
-	    doublereal *, doublereal *, integer *), xerbla_(char *, 
-	    integer *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    doublereal bignum;
-    extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, 
-	    integer *, integer *, doublereal *, integer *, doublereal *, 
-	    doublereal *, integer *, doublereal *, integer *, integer *);
-    integer wlalsd;
-    extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
-	    integer *, doublereal *, integer *, integer *);
-    integer ldwork;
-    extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
-	    integer *, doublereal *, integer *, integer *);
-    integer minwrk, maxwrk;
-    doublereal smlnum;
-    logical lquery;
-    integer smlsiz;
-
-
-/*  -- LAPACK driver routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGELSD computes the minimum-norm solution to a real linear least */
-/*  squares problem: */
-/*      minimize 2-norm(| b - A*x |) */
-/*  using the singular value decomposition (SVD) of A. A is an M-by-N */
-/*  matrix which may be rank-deficient. */
-
-/*  Several right hand side vectors b and solution vectors x can be */
-/*  handled in a single call; they are stored as the columns of the */
-/*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
-/*  matrix X. */
-
-/*  The problem is solved in three steps: */
-/*  (1) Reduce the coefficient matrix A to bidiagonal form with */
-/*      Householder transformations, reducing the original problem */
-/*      into a "bidiagonal least squares problem" (BLS) */
-/*  (2) Solve the BLS using a divide and conquer approach. */
-/*  (3) Apply back all the Householder tranformations to solve */
-/*      the original least squares problem. */
-
-/*  The effective rank of A is determined by treating as zero those */
-/*  singular values which are less than RCOND times the largest singular */
-/*  value. */
-
-/*  The divide and conquer algorithm makes very mild assumptions about */
-/*  floating point arithmetic. It will work on machines with a guard */
-/*  digit in add/subtract, or on those binary machines without guard */
-/*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
-/*  Cray-2. It could conceivably fail on hexadecimal or decimal machines */
-/*  without guard digits, but we know of none. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of A. M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of A. N >= 0. */
-
-/*  NRHS    (input) INTEGER */
-/*          The number of right hand sides, i.e., the number of columns */
-/*          of the matrices B and X. NRHS >= 0. */
-
-/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the M-by-N matrix A. */
-/*          On exit, A has been destroyed. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
-/*          On entry, the M-by-NRHS right hand side matrix B. */
-/*          On exit, B is overwritten by the N-by-NRHS solution */
-/*          matrix X.  If m >= n and RANK = n, the residual */
-/*          sum-of-squares for the solution in the i-th column is given */
-/*          by the sum of squares of elements n+1:m in that column. */
-
-/*  LDB     (input) INTEGER */
-/*          The leading dimension of the array B. LDB >= max(1,max(M,N)). */
-
-/*  S       (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The singular values of A in decreasing order. */
-/*          The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
-
-/*  RCOND   (input) DOUBLE PRECISION */
-/*          RCOND is used to determine the effective rank of A. */
-/*          Singular values S(i) <= RCOND*S(1) are treated as zero. */
-/*          If RCOND < 0, machine precision is used instead. */
-
-/*  RANK    (output) INTEGER */
-/*          The effective rank of A, i.e., the number of singular values */
-/*          which are greater than RCOND*S(1). */
-
-/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
-/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
-
-/*  LWORK   (input) INTEGER */
-/*          The dimension of the array WORK. LWORK must be at least 1. */
-/*          The exact minimum amount of workspace needed depends on M, */
-/*          N and NRHS. As long as LWORK is at least */
-/*              12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, */
-/*          if M is greater than or equal to N or */
-/*              12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, */
-/*          if M is less than N, the code will execute correctly. */
-/*          SMLSIZ is returned by ILAENV and is equal to the maximum */
-/*          size of the subproblems at the bottom of the computation */
-/*          tree (usually about 25), and */
-/*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
-/*          For good performance, LWORK should generally be larger. */
-
-/*          If LWORK = -1, then a workspace query is assumed; the routine */
-/*          only calculates the optimal size of the WORK array, returns */
-/*          this value as the first entry of the WORK array, and no error */
-/*          message related to LWORK is issued by XERBLA. */
-
-/*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
-/*          LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, */
-/*          where MINMN = MIN( M,N ). */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-/*          > 0:  the algorithm for computing the SVD failed to converge; */
-/*                if INFO = i, i off-diagonal elements of an intermediate */
-/*                bidiagonal form did not converge to zero. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Ming Gu and Ren-Cang Li, Computer Science Division, University of */
-/*       California at Berkeley, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input arguments. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-    --s;
-    --work;
-    --iwork;
-
-    /* Function Body */
-    *info = 0;
-    minmn = min(*m,*n);
-    maxmn = max(*m,*n);
-    mnthr = ilaenv_(&c__6, "DGELSD", " ", m, n, nrhs, &c_n1);
-    lquery = *lwork == -1;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*nrhs < 0) {
-	*info = -3;
-    } else if (*lda < max(1,*m)) {
-	*info = -5;
-    } else if (*ldb < max(1,maxmn)) {
-	*info = -7;
-    }
-
-    smlsiz = ilaenv_(&c__9, "DGELSD", " ", &c__0, &c__0, &c__0, &c__0);
-
-/*     Compute workspace. */
-/*     (Note: Comments in the code beginning "Workspace:" describe the */
-/*     minimal amount of workspace needed at that point in the code, */
-/*     as well as the preferred amount for good performance. */
-/*     NB refers to the optimal block size for the immediately */
-/*     following subroutine, as returned by ILAENV.) */
-
-    minwrk = 1;
-    minmn = max(1,minmn);
-/* Computing MAX */
-    i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) / 
-	    log(2.)) + 1;
-    nlvl = max(i__1,0);
-
-    if (*info == 0) {
-	maxwrk = 0;
-	mm = *m;
-	if (*m >= *n && *m >= mnthr) {
-
-/*           Path 1a - overdetermined, with many more rows than columns. */
-
-	    mm = *n;
-/* Computing MAX */
-	    i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, 
-		    n, &c_n1, &c_n1);
-	    maxwrk = max(i__1,i__2);
-/* Computing MAX */
-	    i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT", 
-		    m, nrhs, n, &c_n1);
-	    maxwrk = max(i__1,i__2);
-	}
-	if (*m >= *n) {
-
-/*           Path 1 - overdetermined or exactly determined. */
-
-/* Computing MAX */
-	    i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD"
-, " ", &mm, n, &c_n1, &c_n1);
-	    maxwrk = max(i__1,i__2);
-/* Computing MAX */
-	    i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR", 
-		    "QLT", &mm, nrhs, n, &c_n1);
-	    maxwrk = max(i__1,i__2);
-/* Computing MAX */
-	    i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORMBR", 
-		     "PLN", n, nrhs, n, &c_n1);
-	    maxwrk = max(i__1,i__2);
-/* Computing 2nd power */
-	    i__1 = smlsiz + 1;
-	    wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *
-		    nrhs + i__1 * i__1;
-/* Computing MAX */
-	    i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
-	    maxwrk = max(i__1,i__2);
-/* Computing MAX */
-	    i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2), 
-		    i__2 = *n * 3 + wlalsd;
-	    minwrk = max(i__1,i__2);
-	}
-	if (*n > *m) {
-/* Computing 2nd power */
-	    i__1 = smlsiz + 1;
-	    wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *
-		    nrhs + i__1 * i__1;
-	    if (*n >= mnthr) {
-
-/*              Path 2a - underdetermined, with many more columns */
-/*              than rows. */
-
-		maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, 
-			&c_n1);
-/* Computing MAX */
-		i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * 
-			ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1);
-		maxwrk = max(i__1,i__2);
-/* Computing MAX */
-		i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
-			c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1);
-		maxwrk = max(i__1,i__2);
-/* Computing MAX */
-		i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * 
-			ilaenv_(&c__1, "DORMBR", "PLN", m, nrhs, m, &c_n1);
-		maxwrk = max(i__1,i__2);
-		if (*nrhs > 1) {
-/* Computing MAX */
-		    i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
-		    maxwrk = max(i__1,i__2);
-		} else {
-/* Computing MAX */
-		    i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
-		    maxwrk = max(i__1,i__2);
-		}
-/* Computing MAX */
-		i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ", 
-			"LT", n, nrhs, m, &c_n1);
-		maxwrk = max(i__1,i__2);
-/* Computing MAX */
-		i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
-		maxwrk = max(i__1,i__2);
-/*     XXX: Ensure the Path 2a case below is triggered.  The workspace */
-/*     calculation should use queries for all routines eventually. */
-/* Computing MAX */
-/* Computing MAX */
-		i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
-			 max(i__3,*nrhs), i__4 = *n - *m * 3;
-		i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4);
-		maxwrk = max(i__1,i__2);
-	    } else {
-
-/*              Path 2 - remaining underdetermined cases. */
-
-		maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m, 
-			 n, &c_n1, &c_n1);
-/* Computing MAX */
-		i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR"
-, "QLT", m, nrhs, n, &c_n1);
-		maxwrk = max(i__1,i__2);
-/* Computing MAX */
-		i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR", 
-			"PLN", n, nrhs, m, &c_n1);
-		maxwrk = max(i__1,i__2);
-/* Computing MAX */
-		i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
-		maxwrk = max(i__1,i__2);
-	    }
-/* Computing MAX */
-	    i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2), 
-		    i__2 = *m * 3 + wlalsd;
-	    minwrk = max(i__1,i__2);
-	}
-	minwrk = min(minwrk,maxwrk);
-	work[1] = (doublereal) maxwrk;
-	if (*lwork < minwrk && ! lquery) {
-	    *info = -12;
-	}
-    }
-
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGELSD", &i__1);
-	return 0;
-    } else if (lquery) {
-	goto L10;
-    }
-
-/*     Quick return if possible. */
-
-    if (*m == 0 || *n == 0) {
-	*rank = 0;
-	return 0;
-    }
-
-/*     Get machine parameters. */
-
-    eps = dlamch_("P");
-    sfmin = dlamch_("S");
-    smlnum = sfmin / eps;
-    bignum = 1. / smlnum;
-    dlabad_(&smlnum, &bignum);
-
-/*     Scale A if max entry outside range [SMLNUM,BIGNUM]. */
-
-    anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
-    iascl = 0;
-    if (anrm > 0. && anrm < smlnum) {
-
-/*        Scale matrix norm up to SMLNUM. */
-
-	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
-		info);
-	iascl = 1;
-    } else if (anrm > bignum) {
-
-/*        Scale matrix norm down to BIGNUM. */
-
-	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
-		info);
-	iascl = 2;
-    } else if (anrm == 0.) {
-
-/*        Matrix all zero. Return zero solution. */
-
-	i__1 = max(*m,*n);
-	dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb);
-	dlaset_("F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1);
-	*rank = 0;
-	goto L10;
-    }
-
-/*     Scale B if max entry outside range [SMLNUM,BIGNUM]. */
-
-    bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
-    ibscl = 0;
-    if (bnrm > 0. && bnrm < smlnum) {
-
-/*        Scale matrix norm up to SMLNUM. */
-
-	dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, 
-		 info);
-	ibscl = 1;
-    } else if (bnrm > bignum) {
-
-/*        Scale matrix norm down to BIGNUM. */
-
-	dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, 
-		 info);
-	ibscl = 2;
-    }
-
-/*     If M < N make sure certain entries of B are zero. */
-
-    if (*m < *n) {
-	i__1 = *n - *m;
-	dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb);
-    }
-
-/*     Overdetermined case. */
-
-    if (*m >= *n) {
-
-/*        Path 1 - overdetermined or exactly determined. */
-
-	mm = *m;
-	if (*m >= mnthr) {
-
-/*           Path 1a - overdetermined, with many more rows than columns. */
-
-	    mm = *n;
-	    itau = 1;
-	    nwork = itau + *n;
-
-/*           Compute A=Q*R. */
-/*           (Workspace: need 2*N, prefer N+N*NB) */
-
-	    i__1 = *lwork - nwork + 1;
-	    dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, 
-		     info);
-
-/*           Multiply B by transpose(Q). */
-/*           (Workspace: need N+NRHS, prefer N+NRHS*NB) */
-
-	    i__1 = *lwork - nwork + 1;
-	    dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
-		    b_offset], ldb, &work[nwork], &i__1, info);
-
-/*           Zero out below R. */
-
-	    if (*n > 1) {
-		i__1 = *n - 1;
-		i__2 = *n - 1;
-		dlaset_("L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2], 
-			lda);
-	    }
-	}
-
-	ie = 1;
-	itauq = ie + *n;
-	itaup = itauq + *n;
-	nwork = itaup + *n;
-
-/*        Bidiagonalize R in A. */
-/*        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
-
-	i__1 = *lwork - nwork + 1;
-	dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
-		work[itaup], &work[nwork], &i__1, info);
-
-/*        Multiply B by transpose of left bidiagonalizing vectors of R. */
-/*        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
-
-	i__1 = *lwork - nwork + 1;
-	dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], 
-		&b[b_offset], ldb, &work[nwork], &i__1, info);
-
-/*        Solve the bidiagonal least squares problem. */
-
-	dlalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, 
-		rcond, rank, &work[nwork], &iwork[1], info);
-	if (*info != 0) {
-	    goto L10;
-	}
-
-/*        Multiply B by right bidiagonalizing vectors of R. */
-
-	i__1 = *lwork - nwork + 1;
-	dormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
-		b[b_offset], ldb, &work[nwork], &i__1, info);
-
-    } else /* if(complicated condition) */ {
-/* Computing MAX */
-	i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
-		i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2);
-	if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) {
-
-/*        Path 2a - underdetermined, with many more columns than rows */
-/*        and sufficient workspace for an efficient algorithm. */
-
-	    ldwork = *m;
-/* Computing MAX */
-/* Computing MAX */
-	    i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = 
-		    max(i__3,*nrhs), i__4 = *n - *m * 3;
-	    i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda + 
-		    *m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2) 
-		    + *m * *lda + wlalsd;
-	    if (*lwork >= max(i__1,i__2)) {
-		ldwork = *lda;
-	    }
-	    itau = 1;
-	    nwork = *m + 1;
-
-/*        Compute A=L*Q. */
-/*        (Workspace: need 2*M, prefer M+M*NB) */
-
-	    i__1 = *lwork - nwork + 1;
-	    dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, 
-		     info);
-	    il = nwork;
-
-/*        Copy L to WORK(IL), zeroing out above its diagonal. */
-
-	    dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
-	    i__1 = *m - 1;
-	    i__2 = *m - 1;
-	    dlaset_("U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &
-		    ldwork);
-	    ie = il + ldwork * *m;
-	    itauq = ie + *m;
-	    itaup = itauq + *m;
-	    nwork = itaup + *m;
-
-/*        Bidiagonalize L in WORK(IL). */
-/*        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
-
-	    i__1 = *lwork - nwork + 1;
-	    dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], 
-		    &work[itaup], &work[nwork], &i__1, info);
-
-/*        Multiply B by transpose of left bidiagonalizing vectors of L. */
-/*        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
-
-	    i__1 = *lwork - nwork + 1;
-	    dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
-		    itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
-
-/*        Solve the bidiagonal least squares problem. */
-
-	    dlalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], 
-		    ldb, rcond, rank, &work[nwork], &iwork[1], info);
-	    if (*info != 0) {
-		goto L10;
-	    }
-
-/*        Multiply B by right bidiagonalizing vectors of L. */
-
-	    i__1 = *lwork - nwork + 1;
-	    dormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
-		    itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
-
-/*        Zero out below first M rows of B. */
-
-	    i__1 = *n - *m;
-	    dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], 
-		    ldb);
-	    nwork = itau + *m;
-
-/*        Multiply transpose(Q) by B. */
-/*        (Workspace: need M+NRHS, prefer M+NRHS*NB) */
-
-	    i__1 = *lwork - nwork + 1;
-	    dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
-		    b_offset], ldb, &work[nwork], &i__1, info);
-
-	} else {
-
-/*        Path 2 - remaining underdetermined cases. */
-
-	    ie = 1;
-	    itauq = ie + *m;
-	    itaup = itauq + *m;
-	    nwork = itaup + *m;
-
-/*        Bidiagonalize A. */
-/*        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
-
-	    i__1 = *lwork - nwork + 1;
-	    dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
-		    work[itaup], &work[nwork], &i__1, info);
-
-/*        Multiply B by transpose of left bidiagonalizing vectors. */
-/*        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
-
-	    i__1 = *lwork - nwork + 1;
-	    dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
-, &b[b_offset], ldb, &work[nwork], &i__1, info);
-
-/*        Solve the bidiagonal least squares problem. */
-
-	    dlalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], 
-		    ldb, rcond, rank, &work[nwork], &iwork[1], info);
-	    if (*info != 0) {
-		goto L10;
-	    }
-
-/*        Multiply B by right bidiagonalizing vectors of A. */
-
-	    i__1 = *lwork - nwork + 1;
-	    dormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
-, &b[b_offset], ldb, &work[nwork], &i__1, info);
-
-	}
-    }
-
-/*     Undo scaling. */
-
-    if (iascl == 1) {
-	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, 
-		 info);
-	dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
-		minmn, info);
-    } else if (iascl == 2) {
-	dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, 
-		 info);
-	dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
-		minmn, info);
-    }
-    if (ibscl == 1) {
-	dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, 
-		 info);
-    } else if (ibscl == 2) {
-	dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, 
-		 info);
-    }
-
-L10:
-    work[1] = (doublereal) maxwrk;
-    return 0;
-
-/*     End of DGELSD */
-
-} /* dgelsd_ */

3rdparty/lapack/dgemm.c

@@ -1,389 +0,0 @@
-/* dgemm.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
-	n, integer *k, doublereal *alpha, doublereal *a, integer *lda, 
-	doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, 
-	integer *ldc)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
-	    i__3;
-
-    /* Local variables */
-    integer i__, j, l, info;
-    logical nota, notb;
-    doublereal temp;
-    integer ncola;
-    extern logical lsame_(char *, char *);
-    integer nrowa, nrowb;
-    extern /* Subroutine */ int xerbla_(char *, integer *);
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGEMM  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. */
-
-/*  Arguments */
-/*  ========== */
-
-/*  TRANSA - CHARACTER*1. */
-/*           On entry, TRANSA specifies the form of op( A ) to be used in */
-/*           the matrix multiplication as follows: */
-
-/*              TRANSA = 'N' or 'n',  op( A ) = A. */
-
-/*              TRANSA = 'T' or 't',  op( A ) = A'. */
-
-/*              TRANSA = 'C' or 'c',  op( A ) = A'. */
-
-/*           Unchanged on exit. */
-
-/*  TRANSB - CHARACTER*1. */
-/*           On entry, TRANSB specifies the form of op( B ) to be used in */
-/*           the matrix multiplication as follows: */
-
-/*              TRANSB = 'N' or 'n',  op( B ) = B. */
-
-/*              TRANSB = 'T' or 't',  op( B ) = B'. */
-
-/*              TRANSB = 'C' or 'c',  op( B ) = B'. */
-
-/*           Unchanged on exit. */
-
-/*  M      - INTEGER. */
-/*           On entry,  M  specifies  the number  of rows  of the  matrix */
-/*           op( A )  and of the  matrix  C.  M  must  be at least  zero. */
-/*           Unchanged on exit. */
-
-/*  N      - INTEGER. */
-/*           On entry,  N  specifies the number  of columns of the matrix */
-/*           op( B ) and the number of columns of the matrix C. N must be */
-/*           at least zero. */
-/*           Unchanged on exit. */
-
-/*  K      - INTEGER. */
-/*           On entry,  K  specifies  the number of columns of the matrix */
-/*           op( A ) and the number of rows of the matrix op( B ). K must */
-/*           be at least  zero. */
-/*           Unchanged on exit. */
-
-/*  ALPHA  - DOUBLE PRECISION. */
-/*           On entry, ALPHA specifies the scalar alpha. */
-/*           Unchanged on exit. */
-
-/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
-/*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise. */
-/*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k */
-/*           part of the array  A  must contain the matrix  A,  otherwise */
-/*           the leading  k by m  part of the array  A  must contain  the */
-/*           matrix A. */
-/*           Unchanged on exit. */
-
-/*  LDA    - INTEGER. */
-/*           On entry, LDA specifies the first dimension of A as declared */
-/*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then */
-/*           LDA must be at least  max( 1, m ), otherwise  LDA must be at */
-/*           least  max( 1, k ). */
-/*           Unchanged on exit. */
-
-/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */
-/*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise. */
-/*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n */
-/*           part of the array  B  must contain the matrix  B,  otherwise */
-/*           the leading  n by k  part of the array  B  must contain  the */
-/*           matrix B. */
-/*           Unchanged on exit. */
-
-/*  LDB    - INTEGER. */
-/*           On entry, LDB specifies the first dimension of B as declared */
-/*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then */
-/*           LDB must be at least  max( 1, k ), otherwise  LDB must be at */
-/*           least  max( 1, n ). */
-/*           Unchanged on exit. */
-
-/*  BETA   - DOUBLE PRECISION. */
-/*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is */
-/*           supplied as zero then C need not be set on input. */
-/*           Unchanged on exit. */
-
-/*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
-/*           Before entry, the leading  m by n  part of the array  C must */
-/*           contain the matrix  C,  except when  beta  is zero, in which */
-/*           case C need not be set on entry. */
-/*           On exit, the array  C  is overwritten by the  m by n  matrix */
-/*           ( alpha*op( A )*op( B ) + beta*C ). */
-
-/*  LDC    - INTEGER. */
-/*           On entry, LDC specifies the first dimension of C as declared */
-/*           in  the  calling  (sub)  program.   LDC  must  be  at  least */
-/*           max( 1, m ). */
-/*           Unchanged on exit. */
-
-
-/*  Level 3 Blas routine. */
-
-/*  -- Written on 8-February-1989. */
-/*     Jack Dongarra, Argonne National Laboratory. */
-/*     Iain Duff, AERE Harwell. */
-/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Parameters .. */
-/*     .. */
-
-/*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not */
-/*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows */
-/*     and  columns of  A  and the  number of  rows  of  B  respectively. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-    c_dim1 = *ldc;
-    c_offset = 1 + c_dim1;
-    c__ -= c_offset;
-
-    /* Function Body */
-    nota = lsame_(transa, "N");
-    notb = lsame_(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 && ! lsame_(transa, "C") && ! lsame_(
-	    transa, "T")) {
-	info = 1;
-    } else if (! notb && ! lsame_(transb, "C") && ! 
-	    lsame_(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(1,nrowa)) {
-	info = 8;
-    } else if (*ldb < max(1,nrowb)) {
-	info = 10;
-    } else if (*ldc < max(1,*m)) {
-	info = 13;
-    }
-    if (info != 0) {
-	xerbla_("DGEMM ", &info);
-	return 0;
-    }
-
-/*     Quick return if possible. */
-
-    if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
-	return 0;
-    }
-
-/*     And if  alpha.eq.zero. */
-
-    if (*alpha == 0.) {
-	if (*beta == 0.) {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = *m;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    c__[i__ + j * c_dim1] = 0.;
-/* L10: */
-		}
-/* L20: */
-	    }
-	} else {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = *m;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
-		}
-/* L40: */
-	    }
-	}
-	return 0;
-    }
-
-/*     Start the operations. */
-
-    if (notb) {
-	if (nota) {
-
-/*           Form  C := alpha*A*B + beta*C. */
-
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		if (*beta == 0.) {
-		    i__2 = *m;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[i__ + j * c_dim1] = 0.;
-/* L50: */
-		    }
-		} else if (*beta != 1.) {
-		    i__2 = *m;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L60: */
-		    }
-		}
-		i__2 = *k;
-		for (l = 1; l <= i__2; ++l) {
-		    if (b[l + j * b_dim1] != 0.) {
-			temp = *alpha * b[l + j * b_dim1];
-			i__3 = *m;
-			for (i__ = 1; i__ <= i__3; ++i__) {
-			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
-				    a_dim1];
-/* L70: */
-			}
-		    }
-/* L80: */
-		}
-/* L90: */
-	    }
-	} else {
-
-/*           Form  C := alpha*A'*B + beta*C */
-
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = *m;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    temp = 0.;
-		    i__3 = *k;
-		    for (l = 1; l <= i__3; ++l) {
-			temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
-/* L100: */
-		    }
-		    if (*beta == 0.) {
-			c__[i__ + j * c_dim1] = *alpha * temp;
-		    } else {
-			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
-				i__ + j * c_dim1];
-		    }
-/* L110: */
-		}
-/* L120: */
-	    }
-	}
-    } else {
-	if (nota) {
-
-/*           Form  C := alpha*A*B' + beta*C */
-
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		if (*beta == 0.) {
-		    i__2 = *m;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[i__ + j * c_dim1] = 0.;
-/* L130: */
-		    }
-		} else if (*beta != 1.) {
-		    i__2 = *m;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L140: */
-		    }
-		}
-		i__2 = *k;
-		for (l = 1; l <= i__2; ++l) {
-		    if (b[j + l * b_dim1] != 0.) {
-			temp = *alpha * b[j + l * b_dim1];
-			i__3 = *m;
-			for (i__ = 1; i__ <= i__3; ++i__) {
-			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
-				    a_dim1];
-/* L150: */
-			}
-		    }
-/* L160: */
-		}
-/* L170: */
-	    }
-	} else {
-
-/*           Form  C := alpha*A'*B' + beta*C */
-
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = *m;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    temp = 0.;
-		    i__3 = *k;
-		    for (l = 1; l <= i__3; ++l) {
-			temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
-/* L180: */
-		    }
-		    if (*beta == 0.) {
-			c__[i__ + j * c_dim1] = *alpha * temp;
-		    } else {
-			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
-				i__ + j * c_dim1];
-		    }
-/* L190: */
-		}
-/* L200: */
-	    }
-	}
-    }
-
-    return 0;
-
-/*     End of DGEMM . */
-
-} /* dgemm_ */

3rdparty/lapack/dgemv_custom.c

@@ -1,241 +0,0 @@
-#include "clapack.h"
-
-
-/* Subroutine */ int dgemv_(char *_trans, integer *_m, integer *_n, doublereal *
-	_alpha, doublereal *a, integer *_lda, doublereal *x, integer *_incx, 
-	doublereal *_beta, doublereal *y, integer *_incy)
-{
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGEMV  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. */
-
-/*  Arguments */
-/*  ========== */
-
-/*  TRANS  - CHARACTER*1. */
-/*           On entry, TRANS specifies the operation to be performed as */
-/*           follows: */
-
-/*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y. */
-
-/*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y. */
-
-/*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y. */
-
-/*           Unchanged on exit. */
-
-/*  M      - INTEGER. */
-/*           On entry, M specifies the number of rows of the matrix A. */
-/*           M must be at least zero. */
-/*           Unchanged on exit. */
-
-/*  N      - INTEGER. */
-/*           On entry, N specifies the number of columns of the matrix A. */
-/*           N must be at least zero. */
-/*           Unchanged on exit. */
-
-/*  ALPHA  - DOUBLE PRECISION. */
-/*           On entry, ALPHA specifies the scalar alpha. */
-/*           Unchanged on exit. */
-
-/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/*           Before entry, the leading m by n part of the array A must */
-/*           contain the matrix of coefficients. */
-/*           Unchanged on exit. */
-
-/*  LDA    - INTEGER. */
-/*           On entry, LDA specifies the first dimension of A as declared */
-/*           in the calling (sub) program. LDA must be at least */
-/*           max( 1, m ). */
-/*           Unchanged on exit. */
-
-/*  X      - DOUBLE PRECISION array of DIMENSION at least */
-/*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
-/*           and at least */
-/*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
-/*           Before entry, the incremented array X must contain the */
-/*           vector x. */
-/*           Unchanged on exit. */
-
-/*  INCX   - INTEGER. */
-/*           On entry, INCX specifies the increment for the elements of */
-/*           X. INCX must not be zero. */
-/*           Unchanged on exit. */
-
-/*  BETA   - DOUBLE PRECISION. */
-/*           On entry, BETA specifies the scalar beta. When BETA is */
-/*           supplied as zero then Y need not be set on input. */
-/*           Unchanged on exit. */
-
-/*  Y      - DOUBLE PRECISION array of DIMENSION at least */
-/*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
-/*           and at least */
-/*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
-/*           Before entry with BETA non-zero, the incremented array Y */
-/*           must contain the vector y. On exit, Y is overwritten by the */
-/*           updated vector y. */
-
-/*  INCY   - INTEGER. */
-/*           On entry, INCY specifies the increment for the elements of */
-/*           Y. INCY must not be zero. */
-/*           Unchanged on exit. */
-
-
-/*  Level 2 Blas routine. */
-
-/*  -- Written on 22-October-1986. */
-/*     Jack Dongarra, Argonne National Lab. */
-/*     Jeremy Du Croz, Nag Central Office. */
-/*     Sven Hammarling, Nag Central Office. */
-/*     Richard Hanson, Sandia National Labs. */
-
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-
-/*     Test the input parameters. */
-
-    char trans = lapack_toupper(_trans[0]);
-    integer i, j, m = *_m, n = *_n, lda = *_lda, incx = *_incx, incy = *_incy;
-    integer leny = trans == 'N' ? m : n, lenx = trans == 'N' ? n : m;
-    doublereal alpha = *_alpha, beta = *_beta;
-    
-    integer info = 0;
-    if (trans != 'N' && trans != 'T' && trans != 'C')
-        info = 1;
-    else if (m < 0)
-        info = 2;
-    else if (n < 0)
-        info = 3;
-    else if (lda < max(1,m))
-        info = 6;
-    else if (incx == 0)
-        info = 8;
-    else if (incy == 0)
-        info = 11;
-    
-    if (info != 0)
-    {
-        xerbla_("SGEMV ", &info);
-        return 0;
-    }
-    
-    if( incy < 0 )
-        y -= incy*(leny - 1);
-    if( incx < 0 )
-        x -= incx*(lenx - 1);
-    
-    /*     Start the operations. In this version the elements of A are */
-    /*     accessed sequentially with one pass through A. */
-    
-    if( beta != 1. )
-    {
-        if( incy == 1 )
-        {
-            if( beta == 0. )
-                for( i = 0; i < leny; i++ )
-                    y[i] = 0.;
-            else
-                for( i = 0; i < leny; i++ )
-                    y[i] *= beta;
-        }
-        else
-        {
-            if( beta == 0. )
-                for( i = 0; i < leny; i++ )
-                    y[i*incy] = 0.;
-            else
-                for( i = 0; i < leny; i++ )
-                    y[i*incy] *= beta;
-        }
-    }
-    
-    if( alpha == 0. )
-        ;
-    else if( trans == 'N' )
-    {
-        if( incy == 1 )
-        {
-            for( i = 0; i < n; i++, a += lda )
-            {
-                doublereal s = x[i*incx];
-                if( s == 0. )
-                    continue;
-                s *= alpha;
-                for( j = 0; j <= m - 4; j += 4 )
-                {
-                    doublereal t0 = y[j] + s*a[j];
-                    doublereal t1 = y[j+1] + s*a[j+1];
-                    y[j] = t0; y[j+1] = t1;
-                    t0 = y[j+2] + s*a[j+2];
-                    t1 = y[j+3] + s*a[j+3];
-                    y[j+2] = t0; y[j+3] = t1;
-                }
-                
-                for( ; j < m; j++ )
-                    y[j] += s*a[j];
-            }
-        }
-        else
-        {
-            for( i = 0; i < n; i++, a += lda )
-            {
-                doublereal s = x[i*incx];
-                if( s == 0. )
-                    continue;
-                s *= alpha;
-                for( j = 0; j < m; j++ )
-                    y[j*incy] += s*a[j];
-            }
-        }
-    }
-    else
-    {
-        if( incx == 1 )
-        {
-            for( i = 0; i < n; i++, a += lda )
-            {
-                doublereal s = 0;
-                for( j = 0; j <= m - 4; j += 4 )
-                    s += x[j]*a[j] + x[j+1]*a[j+1] + x[j+2]*a[j+2] + x[j+3]*a[j+3];
-                for( ; j < m; j++ )
-                    s += x[j]*a[j];
-                y[i*incy] += alpha*s;
-            }
-        }
-        else
-        {
-            for( i = 0; i < n; i++, a += lda )
-            {
-                doublereal s = 0;
-                for( j = 0; j < m; j++ )
-                    s += x[j*incx]*a[j];
-                y[i*incy] += alpha*s;
-            }
-        }
-    }
-    
-    return 0;
-
-/*     End of DGEMV . */
-
-} /* dgemv_ */

3rdparty/lapack/dgeqr2.c

@@ -1,161 +0,0 @@
-/* dgeqr2.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-
-/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *
-	lda, doublereal *tau, doublereal *work, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3;
-
-    /* Local variables */
-    integer i__, k;
-    doublereal aii;
-    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *), dlarfp_(integer *, doublereal *, 
-	    doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGEQR2 computes a QR factorization of a real m by n matrix A: */
-/*  A = Q * R. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the m by n matrix A. */
-/*          On exit, the elements on and above the diagonal of the array */
-/*          contain the min(m,n) by n upper trapezoidal matrix R (R is */
-/*          upper triangular if m >= n); the elements below the diagonal, */
-/*          with the array TAU, represent the orthogonal matrix Q as a */
-/*          product of elementary reflectors (see Further Details). */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The scalar factors of the elementary reflectors (see Further */
-/*          Details). */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (N) */
-
-/*  INFO    (output) INTEGER */
-/*          = 0: successful exit */
-/*          < 0: if INFO = -i, the i-th argument had an illegal value */
-
-/*  Further Details */
-/*  =============== */
-
-/*  The matrix Q is represented as a product of elementary reflectors */
-
-/*     Q = H(1) H(2) . . . H(k), where k = min(m,n). */
-
-/*  Each H(i) has the form */
-
-/*     H(i) = I - tau * v * v' */
-
-/*  where tau is a real scalar, and v is a real vector with */
-/*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
-/*  and tau in TAU(i). */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input arguments */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --tau;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*m)) {
-	*info = -4;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGEQR2", &i__1);
-	return 0;
-    }
-
-    k = min(*m,*n);
-
-    i__1 = k;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-
-/*        Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
-
-	i__2 = *m - i__ + 1;
-/* Computing MIN */
-	i__3 = i__ + 1;
-	dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * a_dim1]
-, &c__1, &tau[i__]);
-	if (i__ < *n) {
-
-/*           Apply H(i) to A(i:m,i+1:n) from the left */
-
-	    aii = a[i__ + i__ * a_dim1];
-	    a[i__ + i__ * a_dim1] = 1.;
-	    i__2 = *m - i__ + 1;
-	    i__3 = *n - i__;
-	    dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[
-		    i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
-	    a[i__ + i__ * a_dim1] = aii;
-	}
-/* L10: */
-    }
-    return 0;
-
-/*     End of DGEQR2 */
-
-} /* dgeqr2_ */

3rdparty/lapack/dgeqrf.c

@@ -1,252 +0,0 @@
-/* dgeqrf.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c_n1 = -1;
-static integer c__3 = 3;
-static integer c__2 = 2;
-
-/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
-	lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
-
-    /* Local variables */
-    integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
-    extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, 
-	     char *, char *, char *, integer *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal 
-	    *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    integer ldwork, lwkopt;
-    logical lquery;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGEQRF computes a QR factorization of a real M-by-N matrix A: */
-/*  A = Q * R. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the M-by-N matrix A. */
-/*          On exit, the elements on and above the diagonal of the array */
-/*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
-/*          upper triangular if m >= n); the elements below the diagonal, */
-/*          with the array TAU, represent the orthogonal matrix Q as a */
-/*          product of min(m,n) elementary reflectors (see Further */
-/*          Details). */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N)) */
-/*          The scalar factors of the elementary reflectors (see Further */
-/*          Details). */
-
-/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
-/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
-
-/*  LWORK   (input) INTEGER */
-/*          The dimension of the array WORK.  LWORK >= max(1,N). */
-/*          For optimum performance LWORK >= N*NB, where NB is */
-/*          the optimal blocksize. */
-
-/*          If LWORK = -1, then a workspace query is assumed; the routine */
-/*          only calculates the optimal size of the WORK array, returns */
-/*          this value as the first entry of the WORK array, and no error */
-/*          message related to LWORK is issued by XERBLA. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
-
-/*  Further Details */
-/*  =============== */
-
-/*  The matrix Q is represented as a product of elementary reflectors */
-
-/*     Q = H(1) H(2) . . . H(k), where k = min(m,n). */
-
-/*  Each H(i) has the form */
-
-/*     H(i) = I - tau * v * v' */
-
-/*  where tau is a real scalar, and v is a real vector with */
-/*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
-/*  and tau in TAU(i). */
-
-/*  ===================================================================== */
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input arguments */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --tau;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-    nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
-    lwkopt = *n * nb;
-    work[1] = (doublereal) lwkopt;
-    lquery = *lwork == -1;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*m)) {
-	*info = -4;
-    } else if (*lwork < max(1,*n) && ! lquery) {
-	*info = -7;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGEQRF", &i__1);
-	return 0;
-    } else if (lquery) {
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    k = min(*m,*n);
-    if (k == 0) {
-	work[1] = 1.;
-	return 0;
-    }
-
-    nbmin = 2;
-    nx = 0;
-    iws = *n;
-    if (nb > 1 && nb < k) {
-
-/*        Determine when to cross over from blocked to unblocked code. */
-
-/* Computing MAX */
-	i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1);
-	nx = max(i__1,i__2);
-	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;
-/* Computing MAX */
-		i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
-			c_n1);
-		nbmin = max(i__1,i__2);
-	    }
-	}
-    }
-
-    if (nb >= nbmin && nb < k && nx < k) {
-
-/*        Use blocked code initially */
-
-	i__1 = k - nx;
-	i__2 = nb;
-	for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
-/* Computing MIN */
-	    i__3 = k - i__ + 1;
-	    ib = min(i__3,nb);
-
-/*           Compute the QR factorization of the current block */
-/*           A(i:m,i:i+ib-1) */
-
-	    i__3 = *m - i__ + 1;
-	    dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
-		    1], &iinfo);
-	    if (i__ + ib <= *n) {
-
-/*              Form the triangular factor of the block reflector */
-/*              H = H(i) H(i+1) . . . H(i+ib-1) */
-
-		i__3 = *m - i__ + 1;
-		dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * 
-			a_dim1], lda, &tau[i__], &work[1], &ldwork);
-
-/*              Apply H' to A(i:m,i+ib:n) from the left */
-
-		i__3 = *m - i__ + 1;
-		i__4 = *n - i__ - ib + 1;
-		dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
-			i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
-			ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib 
-			+ 1], &ldwork);
-	    }
-/* L10: */
-	}
-    } else {
-	i__ = 1;
-    }
-
-/*     Use unblocked code to factor the last or only block. */
-
-    if (i__ <= k) {
-	i__2 = *m - i__ + 1;
-	i__1 = *n - i__ + 1;
-	dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
-, &iinfo);
-    }
-
-    work[1] = (doublereal) iws;
-    return 0;
-
-/*     End of DGEQRF */
-
-} /* dgeqrf_ */

3rdparty/lapack/dger_custom.c

@@ -1,165 +0,0 @@
-#include "clapack.h"
-
-
-/* Subroutine */ int dger_(integer *_m, integer *_n, doublereal *_alpha, 
-	doublereal *x, integer *_incx, doublereal *y, integer *_incy, 
-	doublereal *a, integer *_lda)
-{
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGER   performs the rank 1 operation */
-
-/*     A := alpha*x*y' + A, */
-
-/*  where alpha is a scalar, x is an m element vector, y is an n element */
-/*  vector and A is an m by n matrix. */
-
-/*  Arguments */
-/*  ========== */
-
-/*  M      - INTEGER. */
-/*           On entry, M specifies the number of rows of the matrix A. */
-/*           M must be at least zero. */
-/*           Unchanged on exit. */
-
-/*  N      - INTEGER. */
-/*           On entry, N specifies the number of columns of the matrix A. */
-/*           N must be at least zero. */
-/*           Unchanged on exit. */
-
-/*  ALPHA  - DOUBLE PRECISION. */
-/*           On entry, ALPHA specifies the scalar alpha. */
-/*           Unchanged on exit. */
-
-/*  X      - DOUBLE PRECISION array of dimension at least */
-/*           ( 1 + ( m - 1 )*abs( INCX ) ). */
-/*           Before entry, the incremented array X must contain the m */
-/*           element vector x. */
-/*           Unchanged on exit. */
-
-/*  INCX   - INTEGER. */
-/*           On entry, INCX specifies the increment for the elements of */
-/*           X. INCX must not be zero. */
-/*           Unchanged on exit. */
-
-/*  Y      - DOUBLE PRECISION array of dimension at least */
-/*           ( 1 + ( n - 1 )*abs( INCY ) ). */
-/*           Before entry, the incremented array Y must contain the n */
-/*           element vector y. */
-/*           Unchanged on exit. */
-
-/*  INCY   - INTEGER. */
-/*           On entry, INCY specifies the increment for the elements of */
-/*           Y. INCY must not be zero. */
-/*           Unchanged on exit. */
-
-/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/*           Before entry, the leading m by n part of the array A must */
-/*           contain the matrix of coefficients. On exit, A is */
-/*           overwritten by the updated matrix. */
-
-/*  LDA    - INTEGER. */
-/*           On entry, LDA specifies the first dimension of A as declared */
-/*           in the calling (sub) program. LDA must be at least */
-/*           max( 1, m ). */
-/*           Unchanged on exit. */
-
-
-/*  Level 2 Blas routine. */
-
-/*  -- Written on 22-October-1986. */
-/*     Jack Dongarra, Argonne National Lab. */
-/*     Jeremy Du Croz, Nag Central Office. */
-/*     Sven Hammarling, Nag Central Office. */
-/*     Richard Hanson, Sandia National Labs. */
-
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-
-/*     Test the input parameters. */
-
-    /* Function Body */
-    integer i, j, m = *_m, n = *_n, incx = *_incx, incy = *_incy, lda = *_lda;
-    doublereal alpha = *_alpha;
-    integer info = 0;
-    
-    if (m < 0)
-        info = 1;
-    else if (n < 0)
-        info = 2;
-    else if (incx == 0)
-        info = 5;
-    else if (incy == 0)
-        info = 7;
-    else if (lda < max(1,m))
-        info = 9;
-    
-    if (info != 0)
-    {
-        xerbla_("DGER  ", &info);
-        return 0;
-    }
-
-    if (incx < 0)
-        x -= (m-1)*incx;
-    if (incy < 0)
-        y -= (n-1)*incy;
-
-    /*     Start the operations. In this version the elements of A are */
-    /*     accessed sequentially with one pass through A. */
-    
-    if( alpha == 0 )
-        ;
-    else if( incx == 1 )
-    {
-        for( j = 0; j < n; j++, a += lda )
-        {
-            doublereal s = y[j*incy];
-            if( s == 0 )
-                continue;
-            s *= alpha;
-            
-            for( i = 0; i <= m - 2; i += 2 )
-            {
-                doublereal t0 = a[i] + x[i]*s;
-                doublereal t1 = a[i+1] + x[i+1]*s;
-                a[i] = t0; a[i+1] = t1;
-            }
-            
-            for( ; i < m; i++ )
-                a[i] += x[i]*s;
-        }
-    }
-    else
-    {
-        for( j = 0; j < n; j++, a += lda )
-        {
-            doublereal s = y[j*incy];
-            if( s == 0 )
-                continue;
-            s *= alpha;
-            
-            for( i = 0; i < m; i++ )
-                a[i] += x[i*incx]*s;
-        }
-    }
-
-    return 0;
-
-/*     End of DGER  . */
-
-} /* dger_ */

3rdparty/lapack/dgesv.c

@@ -1,138 +0,0 @@
-/* dgesv.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer 
-	*lda, integer *ipiv, doublereal *b, integer *ldb, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
-
-    /* Local variables */
-    extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *, 
-	    integer *, integer *, integer *), xerbla_(char *, integer *), dgetrs_(char *, integer *, integer *, doublereal *, 
-	    integer *, integer *, doublereal *, integer *, integer *);
-
-
-/*  -- LAPACK driver routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGESV computes the solution to a real system of linear equations */
-/*     A * X = B, */
-/*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
-
-/*  The LU decomposition with partial pivoting and row interchanges is */
-/*  used to factor A as */
-/*     A = P * L * U, */
-/*  where P is a permutation matrix, L is unit lower triangular, and U is */
-/*  upper triangular.  The factored form of A is then used to solve the */
-/*  system of equations A * X = B. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The number of linear equations, i.e., the order of the */
-/*          matrix A.  N >= 0. */
-
-/*  NRHS    (input) INTEGER */
-/*          The number of right hand sides, i.e., the number of columns */
-/*          of the matrix B.  NRHS >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the N-by-N coefficient matrix A. */
-/*          On exit, the factors L and U from the factorization */
-/*          A = P*L*U; the unit diagonal elements of L are not stored. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,N). */
-
-/*  IPIV    (output) INTEGER array, dimension (N) */
-/*          The pivot indices that define the permutation matrix P; */
-/*          row i of the matrix was interchanged with row IPIV(i). */
-
-/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
-/*          On entry, the N-by-NRHS matrix of right hand side matrix B. */
-/*          On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
-
-/*  LDB     (input) INTEGER */
-/*          The leading dimension of the array B.  LDB >= max(1,N). */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
-/*          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization */
-/*                has been completed, but the factor U is exactly */
-/*                singular, so the solution could not be computed. */
-
-/*  ===================================================================== */
-
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --ipiv;
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-
-    /* Function Body */
-    *info = 0;
-    if (*n < 0) {
-	*info = -1;
-    } else if (*nrhs < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*n)) {
-	*info = -4;
-    } else if (*ldb < max(1,*n)) {
-	*info = -7;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGESV ", &i__1);
-	return 0;
-    }
-
-/*     Compute the LU factorization of A. */
-
-    dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
-    if (*info == 0) {
-
-/*        Solve the system A*X = B, overwriting B with X. */
-
-	dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
-		b_offset], ldb, info);
-    }
-    return 0;
-
-/*     End of DGESV */
-
-} /* dgesv_ */

3rdparty/lapack/dgetf2.c

@@ -1,193 +0,0 @@
-/* dgetf2.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static doublereal c_b8 = -1.;
-
-/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer *
-	lda, integer *ipiv, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3;
-    doublereal d__1;
-
-    /* Local variables */
-    integer i__, j, jp;
-    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
-	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
-	    integer *), dscal_(integer *, doublereal *, doublereal *, integer 
-	    *);
-    doublereal sfmin;
-    extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *);
-    extern doublereal dlamch_(char *);
-    extern integer idamax_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGETF2 computes an LU factorization of a general m-by-n matrix A */
-/*  using partial pivoting with row interchanges. */
-
-/*  The factorization has the form */
-/*     A = P * L * U */
-/*  where P is a permutation matrix, L is lower triangular with unit */
-/*  diagonal elements (lower trapezoidal if m > n), and U is upper */
-/*  triangular (upper trapezoidal if m < n). */
-
-/*  This is the right-looking Level 2 BLAS version of the algorithm. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the m by n matrix to be factored. */
-/*          On exit, the factors L and U from the factorization */
-/*          A = P*L*U; the unit diagonal elements of L are not stored. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  IPIV    (output) INTEGER array, dimension (min(M,N)) */
-/*          The pivot indices; for 1 <= i <= min(M,N), row i of the */
-/*          matrix was interchanged with row IPIV(i). */
-
-/*  INFO    (output) INTEGER */
-/*          = 0: successful exit */
-/*          < 0: if INFO = -k, the k-th argument had an illegal value */
-/*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
-/*               has been completed, but the factor U is exactly */
-/*               singular, and division by zero will occur if it is used */
-/*               to solve a system of equations. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --ipiv;
-
-    /* Function Body */
-    *info = 0;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*m)) {
-	*info = -4;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGETF2", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*m == 0 || *n == 0) {
-	return 0;
-    }
-
-/*     Compute machine safe minimum */
-
-    sfmin = dlamch_("S");
-
-    i__1 = min(*m,*n);
-    for (j = 1; j <= i__1; ++j) {
-
-/*        Find pivot and test for singularity. */
-
-	i__2 = *m - j + 1;
-	jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1);
-	ipiv[j] = jp;
-	if (a[jp + j * a_dim1] != 0.) {
-
-/*           Apply the interchange to columns 1:N. */
-
-	    if (jp != j) {
-		dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
-	    }
-
-/*           Compute elements J+1:M of J-th column. */
-
-	    if (j < *m) {
-		if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) {
-		    i__2 = *m - j;
-		    d__1 = 1. / a[j + j * a_dim1];
-		    dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
-		} else {
-		    i__2 = *m - j;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
-/* L20: */
-		    }
-		}
-	    }
-
-	} else if (*info == 0) {
-
-	    *info = j;
-	}
-
-	if (j < min(*m,*n)) {
-
-/*           Update trailing submatrix. */
-
-	    i__2 = *m - j;
-	    i__3 = *n - j;
-	    dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + (
-		    j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda);
-	}
-/* L10: */
-    }
-    return 0;
-
-/*     End of DGETF2 */
-
-} /* dgetf2_ */

3rdparty/lapack/dgetrf.c

@@ -1,219 +0,0 @@
-/* dgetrf.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c_n1 = -1;
-static doublereal c_b16 = 1.;
-static doublereal c_b19 = -1.;
-
-/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *
-	lda, integer *ipiv, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
-
-    /* Local variables */
-    integer i__, j, jb, nb;
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *);
-    integer iinfo;
-    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, 
-	    integer *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *, integer *), dgetf2_(
-	    integer *, integer *, doublereal *, integer *, integer *, integer 
-	    *), xerbla_(char *, integer *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *, 
-	    integer *, integer *, integer *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGETRF computes an LU factorization of a general M-by-N matrix A */
-/*  using partial pivoting with row interchanges. */
-
-/*  The factorization has the form */
-/*     A = P * L * U */
-/*  where P is a permutation matrix, L is lower triangular with unit */
-/*  diagonal elements (lower trapezoidal if m > n), and U is upper */
-/*  triangular (upper trapezoidal if m < n). */
-
-/*  This is the right-looking Level 3 BLAS version of the algorithm. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the M-by-N matrix to be factored. */
-/*          On exit, the factors L and U from the factorization */
-/*          A = P*L*U; the unit diagonal elements of L are not stored. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  IPIV    (output) INTEGER array, dimension (min(M,N)) */
-/*          The pivot indices; for 1 <= i <= min(M,N), row i of the */
-/*          matrix was interchanged with row IPIV(i). */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
-/*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization */
-/*                has been completed, but the factor U is exactly */
-/*                singular, and division by zero will occur if it is used */
-/*                to solve a system of equations. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --ipiv;
-
-    /* Function Body */
-    *info = 0;
-    if (*m < 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*lda < max(1,*m)) {
-	*info = -4;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGETRF", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*m == 0 || *n == 0) {
-	return 0;
-    }
-
-/*     Determine the block size for this environment. */
-
-    nb = ilaenv_(&c__1, "DGETRF", " ", m, n, &c_n1, &c_n1);
-    if (nb <= 1 || nb >= min(*m,*n)) {
-
-/*        Use unblocked code. */
-
-	dgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
-    } else {
-
-/*        Use blocked code. */
-
-	i__1 = min(*m,*n);
-	i__2 = nb;
-	for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
-/* Computing MIN */
-	    i__3 = min(*m,*n) - j + 1;
-	    jb = min(i__3,nb);
-
-/*           Factor diagonal and subdiagonal blocks and test for exact */
-/*           singularity. */
-
-	    i__3 = *m - j + 1;
-	    dgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
-
-/*           Adjust INFO and the pivot indices. */
-
-	    if (*info == 0 && iinfo > 0) {
-		*info = iinfo + j - 1;
-	    }
-/* Computing MIN */
-	    i__4 = *m, i__5 = j + jb - 1;
-	    i__3 = min(i__4,i__5);
-	    for (i__ = j; i__ <= i__3; ++i__) {
-		ipiv[i__] = j - 1 + ipiv[i__];
-/* L10: */
-	    }
-
-/*           Apply interchanges to columns 1:J-1. */
-
-	    i__3 = j - 1;
-	    i__4 = j + jb - 1;
-	    dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
-
-	    if (j + jb <= *n) {
-
-/*              Apply interchanges to columns J+JB:N. */
-
-		i__3 = *n - j - jb + 1;
-		i__4 = j + jb - 1;
-		dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
-			ipiv[1], &c__1);
-
-/*              Compute block row of U. */
-
-		i__3 = *n - j - jb + 1;
-		dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
-			c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) * 
-			a_dim1], lda);
-		if (j + jb <= *m) {
-
-/*                 Update trailing submatrix. */
-
-		    i__3 = *m - j - jb + 1;
-		    i__4 = *n - j - jb + 1;
-		    dgemm_("No transpose", "No transpose", &i__3, &i__4, &jb, 
-			    &c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j + 
-			    jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) *
-			     a_dim1], lda);
-		}
-	    }
-/* L20: */
-	}
-    }
-    return 0;
-
-/*     End of DGETRF */
-
-} /* dgetrf_ */

3rdparty/lapack/dgetri.c

@@ -1,264 +0,0 @@
-/* dgetri.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c_n1 = -1;
-static integer c__2 = 2;
-static doublereal c_b20 = -1.;
-static doublereal c_b22 = 1.;
-
-/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer 
-	*ipiv, doublereal *work, integer *lwork, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2, i__3;
-
-    /* Local variables */
-    integer i__, j, jb, nb, jj, jp, nn, iws;
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *),
-	     dgemv_(char *, integer *, integer *, doublereal *, doublereal *, 
-	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
-	    integer *);
-    integer nbmin;
-    extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *), dtrsm_(char *, char *, char *, char *, 
-	    integer *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *, integer *), xerbla_(
-	    char *, integer *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    integer ldwork;
-    extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal 
-	    *, integer *, integer *);
-    integer lwkopt;
-    logical lquery;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGETRI computes the inverse of a matrix using the LU factorization */
-/*  computed by DGETRF. */
-
-/*  This method inverts U and then computes inv(A) by solving the system */
-/*  inv(A)*L = inv(U) for inv(A). */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix A.  N >= 0. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the factors L and U from the factorization */
-/*          A = P*L*U as computed by DGETRF. */
-/*          On exit, if INFO = 0, the inverse of the original matrix A. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,N). */
-
-/*  IPIV    (input) INTEGER array, dimension (N) */
-/*          The pivot indices from DGETRF; for 1<=i<=N, row i of the */
-/*          matrix was interchanged with row IPIV(i). */
-
-/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
-/*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */
-
-/*  LWORK   (input) INTEGER */
-/*          The dimension of the array WORK.  LWORK >= max(1,N). */
-/*          For optimal performance LWORK >= N*NB, where NB is */
-/*          the optimal blocksize returned by ILAENV. */
-
-/*          If LWORK = -1, then a workspace query is assumed; the routine */
-/*          only calculates the optimal size of the WORK array, returns */
-/*          this value as the first entry of the WORK array, and no error */
-/*          message related to LWORK is issued by XERBLA. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
-/*          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is */
-/*                singular and its inverse could not be computed. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --ipiv;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-    nb = ilaenv_(&c__1, "DGETRI", " ", n, &c_n1, &c_n1, &c_n1);
-    lwkopt = *n * nb;
-    work[1] = (doublereal) lwkopt;
-    lquery = *lwork == -1;
-    if (*n < 0) {
-	*info = -1;
-    } else if (*lda < max(1,*n)) {
-	*info = -3;
-    } else if (*lwork < max(1,*n) && ! lquery) {
-	*info = -6;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGETRI", &i__1);
-	return 0;
-    } else if (lquery) {
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0) {
-	return 0;
-    }
-
-/*     Form inv(U).  If INFO > 0 from DTRTRI, then U is singular, */
-/*     and the inverse is not computed. */
-
-    dtrtri_("Upper", "Non-unit", n, &a[a_offset], lda, info);
-    if (*info > 0) {
-	return 0;
-    }
-
-    nbmin = 2;
-    ldwork = *n;
-    if (nb > 1 && nb < *n) {
-/* Computing MAX */
-	i__1 = ldwork * nb;
-	iws = max(i__1,1);
-	if (*lwork < iws) {
-	    nb = *lwork / ldwork;
-/* Computing MAX */
-	    i__1 = 2, i__2 = ilaenv_(&c__2, "DGETRI", " ", n, &c_n1, &c_n1, &
-		    c_n1);
-	    nbmin = max(i__1,i__2);
-	}
-    } else {
-	iws = *n;
-    }
-
-/*     Solve the equation inv(A)*L = inv(U) for inv(A). */
-
-    if (nb < nbmin || nb >= *n) {
-
-/*        Use unblocked code. */
-
-	for (j = *n; j >= 1; --j) {
-
-/*           Copy current column of L to WORK and replace with zeros. */
-
-	    i__1 = *n;
-	    for (i__ = j + 1; i__ <= i__1; ++i__) {
-		work[i__] = a[i__ + j * a_dim1];
-		a[i__ + j * a_dim1] = 0.;
-/* L10: */
-	    }
-
-/*           Compute current column of inv(A). */
-
-	    if (j < *n) {
-		i__1 = *n - j;
-		dgemv_("No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1 
-			+ 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1 
-			+ 1], &c__1);
-	    }
-/* L20: */
-	}
-    } else {
-
-/*        Use blocked code. */
-
-	nn = (*n - 1) / nb * nb + 1;
-	i__1 = -nb;
-	for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
-/* Computing MIN */
-	    i__2 = nb, i__3 = *n - j + 1;
-	    jb = min(i__2,i__3);
-
-/*           Copy current block column of L to WORK and replace with */
-/*           zeros. */
-
-	    i__2 = j + jb - 1;
-	    for (jj = j; jj <= i__2; ++jj) {
-		i__3 = *n;
-		for (i__ = jj + 1; i__ <= i__3; ++i__) {
-		    work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1];
-		    a[i__ + jj * a_dim1] = 0.;
-/* L30: */
-		}
-/* L40: */
-	    }
-
-/*           Compute current block column of inv(A). */
-
-	    if (j + jb <= *n) {
-		i__2 = *n - j - jb + 1;
-		dgemm_("No transpose", "No transpose", n, &jb, &i__2, &c_b20, 
-			&a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &
-			ldwork, &c_b22, &a[j * a_dim1 + 1], lda);
-	    }
-	    dtrsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b22, &
-		    work[j], &ldwork, &a[j * a_dim1 + 1], lda);
-/* L50: */
-	}
-    }
-
-/*     Apply column interchanges. */
-
-    for (j = *n - 1; j >= 1; --j) {
-	jp = ipiv[j];
-	if (jp != j) {
-	    dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
-	}
-/* L60: */
-    }
-
-    work[1] = (doublereal) iws;
-    return 0;
-
-/*     End of DGETRI */
-
-} /* dgetri_ */

3rdparty/lapack/dgetrs.c

@@ -1,186 +0,0 @@
-/* dgetrs.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static doublereal c_b12 = 1.;
-static integer c_n1 = -1;
-
-/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs, 
-	doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
-	ldb, integer *info)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
-
-    /* Local variables */
-    extern logical lsame_(char *, char *);
-    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, 
-	    integer *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *, integer *), xerbla_(
-	    char *, integer *), dlaswp_(integer *, doublereal *, 
-	    integer *, integer *, integer *, integer *, integer *);
-    logical notran;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DGETRS solves a system of linear equations */
-/*     A * X = B  or  A' * X = B */
-/*  with a general N-by-N matrix A using the LU factorization computed */
-/*  by DGETRF. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  TRANS   (input) CHARACTER*1 */
-/*          Specifies the form of the system of equations: */
-/*          = 'N':  A * X = B  (No transpose) */
-/*          = 'T':  A'* X = B  (Transpose) */
-/*          = 'C':  A'* X = B  (Conjugate transpose = Transpose) */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix A.  N >= 0. */
-
-/*  NRHS    (input) INTEGER */
-/*          The number of right hand sides, i.e., the number of columns */
-/*          of the matrix B.  NRHS >= 0. */
-
-/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          The factors L and U from the factorization A = P*L*U */
-/*          as computed by DGETRF. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,N). */
-
-/*  IPIV    (input) INTEGER array, dimension (N) */
-/*          The pivot indices from DGETRF; for 1<=i<=N, row i of the */
-/*          matrix was interchanged with row IPIV(i). */
-
-/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
-/*          On entry, the right hand side matrix B. */
-/*          On exit, the solution matrix X. */
-
-/*  LDB     (input) INTEGER */
-/*          The leading dimension of the array B.  LDB >= max(1,N). */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --ipiv;
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-
-    /* Function Body */
-    *info = 0;
-    notran = lsame_(trans, "N");
-    if (! notran && ! lsame_(trans, "T") && ! lsame_(
-	    trans, "C")) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*nrhs < 0) {
-	*info = -3;
-    } else if (*lda < max(1,*n)) {
-	*info = -5;
-    } else if (*ldb < max(1,*n)) {
-	*info = -8;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DGETRS", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0 || *nrhs == 0) {
-	return 0;
-    }
-
-    if (notran) {
-
-/*        Solve A * X = B. */
-
-/*        Apply row interchanges to the right hand sides. */
-
-	dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
-
-/*        Solve L*X = B, overwriting B with X. */
-
-	dtrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[
-		a_offset], lda, &b[b_offset], ldb);
-
-/*        Solve U*X = B, overwriting B with X. */
-
-	dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, &
-		a[a_offset], lda, &b[b_offset], ldb);
-    } else {
-
-/*        Solve A' * X = B. */
-
-/*        Solve U'*X = B, overwriting B with X. */
-
-	dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[
-		a_offset], lda, &b[b_offset], ldb);
-
-/*        Solve L'*X = B, overwriting B with X. */
-
-	dtrsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[
-		a_offset], lda, &b[b_offset], ldb);
-
-/*        Apply row interchanges to the solution vectors. */
-
-	dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
-    }
-
-    return 0;
-
-/*     End of DGETRS */
-
-} /* dgetrs_ */

3rdparty/lapack/dlabad.c

@@ -1,72 +0,0 @@
-/* dlabad.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlabad_(doublereal *small, doublereal *large)
-{
-    /* Builtin functions */
-    double d_lg10(doublereal *), sqrt(doublereal);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLABAD takes as input the values computed by DLAMCH for underflow and */
-/*  overflow, and returns the square root of each of these values if the */
-/*  log of LARGE is sufficiently large.  This subroutine is intended to */
-/*  identify machines with a large exponent range, such as the Crays, and */
-/*  redefine the underflow and overflow limits to be the square roots of */
-/*  the values computed by DLAMCH.  This subroutine is needed because */
-/*  DLAMCH does not compensate for poor arithmetic in the upper half of */
-/*  the exponent range, as is found on a Cray. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  SMALL   (input/output) DOUBLE PRECISION */
-/*          On entry, the underflow threshold as computed by DLAMCH. */
-/*          On exit, if LOG10(LARGE) is sufficiently large, the square */
-/*          root of SMALL, otherwise unchanged. */
-
-/*  LARGE   (input/output) DOUBLE PRECISION */
-/*          On entry, the overflow threshold as computed by DLAMCH. */
-/*          On exit, if LOG10(LARGE) is sufficiently large, the square */
-/*          root of LARGE, otherwise unchanged. */
-
-/*  ===================================================================== */
-
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     If it looks like we're on a Cray, take the square root of */
-/*     SMALL and LARGE to avoid overflow and underflow problems. */
-
-    if (d_lg10(large) > 2e3) {
-	*small = sqrt(*small);
-	*large = sqrt(*large);
-    }
-
-    return 0;
-
-/*     End of DLABAD */
-
-} /* dlabad_ */

3rdparty/lapack/dlabrd.c

@@ -1,434 +0,0 @@
-/* dlabrd.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static doublereal c_b4 = -1.;
-static doublereal c_b5 = 1.;
-static integer c__1 = 1;
-static doublereal c_b16 = 0.;
-
-/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal *
-	a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq, 
-	doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer 
-	*ldy)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, 
-	    i__3;
-
-    /* Local variables */
-    integer i__;
-    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
-	    integer *), dgemv_(char *, integer *, integer *, doublereal *, 
-	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
-	    doublereal *, integer *), dlarfg_(integer *, doublereal *, 
-	     doublereal *, integer *, doublereal *);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLABRD reduces the first NB rows and columns of a real general */
-/*  m by n matrix A to upper or lower bidiagonal form by an orthogonal */
-/*  transformation Q' * A * P, and returns the matrices X and Y which */
-/*  are needed to apply the transformation to the unreduced part of A. */
-
-/*  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
-/*  bidiagonal form. */
-
-/*  This is an auxiliary routine called by DGEBRD */
-
-/*  Arguments */
-/*  ========= */
-
-/*  M       (input) INTEGER */
-/*          The number of rows in the matrix A. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns in the matrix A. */
-
-/*  NB      (input) INTEGER */
-/*          The number of leading rows and columns of A to be reduced. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          On entry, the m by n general matrix to be reduced. */
-/*          On exit, the first NB rows and columns of the matrix are */
-/*          overwritten; the rest of the array is unchanged. */
-/*          If m >= n, elements on and below the diagonal in the first NB */
-/*            columns, with the array TAUQ, represent the orthogonal */
-/*            matrix Q as a product of elementary reflectors; and */
-/*            elements above the diagonal in the first NB rows, with the */
-/*            array TAUP, represent the orthogonal matrix P as a product */
-/*            of elementary reflectors. */
-/*          If m < n, elements below the diagonal in the first NB */
-/*            columns, with the array TAUQ, represent the orthogonal */
-/*            matrix Q as a product of elementary reflectors, and */
-/*            elements on and above the diagonal in the first NB rows, */
-/*            with the array TAUP, represent the orthogonal matrix P as */
-/*            a product of elementary reflectors. */
-/*          See Further Details. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  D       (output) DOUBLE PRECISION array, dimension (NB) */
-/*          The diagonal elements of the first NB rows and columns of */
-/*          the reduced matrix.  D(i) = A(i,i). */
-
-/*  E       (output) DOUBLE PRECISION array, dimension (NB) */
-/*          The off-diagonal elements of the first NB rows and columns of */
-/*          the reduced matrix. */
-
-/*  TAUQ    (output) DOUBLE PRECISION array dimension (NB) */
-/*          The scalar factors of the elementary reflectors which */
-/*          represent the orthogonal matrix Q. See Further Details. */
-
-/*  TAUP    (output) DOUBLE PRECISION array, dimension (NB) */
-/*          The scalar factors of the elementary reflectors which */
-/*          represent the orthogonal matrix P. See Further Details. */
-
-/*  X       (output) DOUBLE PRECISION array, dimension (LDX,NB) */
-/*          The m-by-nb matrix X required to update the unreduced part */
-/*          of A. */
-
-/*  LDX     (input) INTEGER */
-/*          The leading dimension of the array X. LDX >= M. */
-
-/*  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB) */
-/*          The n-by-nb matrix Y required to update the unreduced part */
-/*          of A. */
-
-/*  LDY     (input) INTEGER */
-/*          The leading dimension of the array Y. LDY >= N. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  The matrices Q and P are represented as products of elementary */
-/*  reflectors: */
-
-/*     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb) */
-
-/*  Each H(i) and G(i) has the form: */
-
-/*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u' */
-
-/*  where tauq and taup are real scalars, and v and u are real vectors. */
-
-/*  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
-/*  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
-/*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
-
-/*  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
-/*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
-/*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
-
-/*  The elements of the vectors v and u together form the m-by-nb matrix */
-/*  V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
-/*  the transformation to the unreduced part of the matrix, using a block */
-/*  update of the form:  A := A - V*Y' - X*U'. */
-
-/*  The contents of A on exit are illustrated by the following examples */
-/*  with nb = 2: */
-
-/*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n): */
-
-/*    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 ) */
-/*    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 ) */
-/*    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  ) */
-/*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  ) */
-/*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  ) */
-/*    (  v1  v2  a   a   a  ) */
-
-/*  where a denotes an element of the original matrix which is unchanged, */
-/*  vi denotes an element of the vector defining H(i), and ui an element */
-/*  of the vector defining G(i). */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Quick return if possible */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --d__;
-    --e;
-    --tauq;
-    --taup;
-    x_dim1 = *ldx;
-    x_offset = 1 + x_dim1;
-    x -= x_offset;
-    y_dim1 = *ldy;
-    y_offset = 1 + y_dim1;
-    y -= y_offset;
-
-    /* Function Body */
-    if (*m <= 0 || *n <= 0) {
-	return 0;
-    }
-
-    if (*m >= *n) {
-
-/*        Reduce to upper bidiagonal form */
-
-	i__1 = *nb;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-
-/*           Update A(i:m,i) */
-
-	    i__2 = *m - i__ + 1;
-	    i__3 = i__ - 1;
-	    dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda, 
-		     &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], &
-		    c__1);
-	    i__2 = *m - i__ + 1;
-	    i__3 = i__ - 1;
-	    dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx, 
-		     &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ * 
-		    a_dim1], &c__1);
-
-/*           Generate reflection Q(i) to annihilate A(i+1:m,i) */
-
-	    i__2 = *m - i__ + 1;
-/* Computing MIN */
-	    i__3 = i__ + 1;
-	    dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * 
-		    a_dim1], &c__1, &tauq[i__]);
-	    d__[i__] = a[i__ + i__ * a_dim1];
-	    if (i__ < *n) {
-		a[i__ + i__ * a_dim1] = 1.;
-
-/*              Compute Y(i+1:n,i) */
-
-		i__2 = *m - i__ + 1;
-		i__3 = *n - i__;
-		dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) * 
-			a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &
-			y[i__ + 1 + i__ * y_dim1], &c__1);
-		i__2 = *m - i__ + 1;
-		i__3 = i__ - 1;
-		dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], 
-			lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * 
-			y_dim1 + 1], &c__1);
-		i__2 = *n - i__;
-		i__3 = i__ - 1;
-		dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + 
-			y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
-			i__ + 1 + i__ * y_dim1], &c__1);
-		i__2 = *m - i__ + 1;
-		i__3 = i__ - 1;
-		dgemv_("Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1], 
-			ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * 
-			y_dim1 + 1], &c__1);
-		i__2 = i__ - 1;
-		i__3 = *n - i__;
-		dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * 
-			a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, 
-			&y[i__ + 1 + i__ * y_dim1], &c__1);
-		i__2 = *n - i__;
-		dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
-
-/*              Update A(i,i+1:n) */
-
-		i__2 = *n - i__;
-		dgemv_("No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + 
-			y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + (
-			i__ + 1) * a_dim1], lda);
-		i__2 = i__ - 1;
-		i__3 = *n - i__;
-		dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * 
-			a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[
-			i__ + (i__ + 1) * a_dim1], lda);
-
-/*              Generate reflection P(i) to annihilate A(i,i+2:n) */
-
-		i__2 = *n - i__;
-/* Computing MIN */
-		i__3 = i__ + 2;
-		dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
-			i__3, *n)* a_dim1], lda, &taup[i__]);
-		e[i__] = a[i__ + (i__ + 1) * a_dim1];
-		a[i__ + (i__ + 1) * a_dim1] = 1.;
-
-/*              Compute X(i+1:m,i) */
-
-		i__2 = *m - i__;
-		i__3 = *n - i__;
-		dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ 
-			+ 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], 
-			lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1);
-		i__2 = *n - i__;
-		dgemv_("Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], 
-			ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[
-			i__ * x_dim1 + 1], &c__1);
-		i__2 = *m - i__;
-		dgemv_("No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 + 
-			a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
-			i__ + 1 + i__ * x_dim1], &c__1);
-		i__2 = i__ - 1;
-		i__3 = *n - i__;
-		dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * 
-			a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
-			c_b16, &x[i__ * x_dim1 + 1], &c__1);
-		i__2 = *m - i__;
-		i__3 = i__ - 1;
-		dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + 
-			x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
-			i__ + 1 + i__ * x_dim1], &c__1);
-		i__2 = *m - i__;
-		dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
-	    }
-/* L10: */
-	}
-    } else {
-
-/*        Reduce to lower bidiagonal form */
-
-	i__1 = *nb;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-
-/*           Update A(i,i:n) */
-
-	    i__2 = *n - i__ + 1;
-	    i__3 = i__ - 1;
-	    dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy, 
-		     &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1], 
-		    lda);
-	    i__2 = i__ - 1;
-	    i__3 = *n - i__ + 1;
-	    dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1], 
-		    lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1], 
-		     lda);
-
-/*           Generate reflection P(i) to annihilate A(i,i+1:n) */
-
-	    i__2 = *n - i__ + 1;
-/* Computing MIN */
-	    i__3 = i__ + 1;
-	    dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)* 
-		    a_dim1], lda, &taup[i__]);
-	    d__[i__] = a[i__ + i__ * a_dim1];
-	    if (i__ < *m) {
-		a[i__ + i__ * a_dim1] = 1.;
-
-/*              Compute X(i+1:m,i) */
-
-		i__2 = *m - i__;
-		i__3 = *n - i__ + 1;
-		dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ *
-			 a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &
-			x[i__ + 1 + i__ * x_dim1], &c__1);
-		i__2 = *n - i__ + 1;
-		i__3 = i__ - 1;
-		dgemv_("Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], 
-			ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * 
-			x_dim1 + 1], &c__1);
-		i__2 = *m - i__;
-		i__3 = i__ - 1;
-		dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + 
-			a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
-			i__ + 1 + i__ * x_dim1], &c__1);
-		i__2 = i__ - 1;
-		i__3 = *n - i__ + 1;
-		dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 + 
-			1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
-			 x_dim1 + 1], &c__1);
-		i__2 = *m - i__;
-		i__3 = i__ - 1;
-		dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + 
-			x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
-			i__ + 1 + i__ * x_dim1], &c__1);
-		i__2 = *m - i__;
-		dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
-
-/*              Update A(i+1:m,i) */
-
-		i__2 = *m - i__;
-		i__3 = i__ - 1;
-		dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + 
-			a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + 
-			1 + i__ * a_dim1], &c__1);
-		i__2 = *m - i__;
-		dgemv_("No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 + 
-			x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[
-			i__ + 1 + i__ * a_dim1], &c__1);
-
-/*              Generate reflection Q(i) to annihilate A(i+2:m,i) */
-
-		i__2 = *m - i__;
-/* Computing MIN */
-		i__3 = i__ + 2;
-		dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m)+ 
-			i__ * a_dim1], &c__1, &tauq[i__]);
-		e[i__] = a[i__ + 1 + i__ * a_dim1];
-		a[i__ + 1 + i__ * a_dim1] = 1.;
-
-/*              Compute Y(i+1:n,i) */
-
-		i__2 = *m - i__;
-		i__3 = *n - i__;
-		dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + 
-			1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, 
-			&c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1);
-		i__2 = *m - i__;
-		i__3 = i__ - 1;
-		dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], 
-			 lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
-			i__ * y_dim1 + 1], &c__1);
-		i__2 = *n - i__;
-		i__3 = i__ - 1;
-		dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + 
-			y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
-			i__ + 1 + i__ * y_dim1], &c__1);
-		i__2 = *m - i__;
-		dgemv_("Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1], 
-			ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
-			i__ * y_dim1 + 1], &c__1);
-		i__2 = *n - i__;
-		dgemv_("Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1 
-			+ 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ 
-			+ 1 + i__ * y_dim1], &c__1);
-		i__2 = *n - i__;
-		dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
-	    }
-/* L20: */
-	}
-    }
-    return 0;
-
-/*     End of DLABRD */
-
-} /* dlabrd_ */

3rdparty/lapack/dlacpy.c

@@ -1,125 +0,0 @@
-/* dlacpy.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal *
-	a, integer *lda, doublereal *b, integer *ldb)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
-
-    /* Local variables */
-    integer i__, j;
-    extern logical lsame_(char *, char *);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLACPY copies all or part of a two-dimensional matrix A to another */
-/*  matrix B. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  UPLO    (input) CHARACTER*1 */
-/*          Specifies the part of the matrix A to be copied to B. */
-/*          = 'U':      Upper triangular part */
-/*          = 'L':      Lower triangular part */
-/*          Otherwise:  All of the matrix A */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0. */
-
-/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          The m by n matrix A.  If UPLO = 'U', only the upper triangle */
-/*          or trapezoid is accessed; if UPLO = 'L', only the lower */
-/*          triangle or trapezoid is accessed. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(1,M). */
-
-/*  B       (output) DOUBLE PRECISION array, dimension (LDB,N) */
-/*          On exit, B = A in the locations specified by UPLO. */
-
-/*  LDB     (input) INTEGER */
-/*          The leading dimension of the array B.  LDB >= max(1,M). */
-
-/*  ===================================================================== */
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-
-    /* Function Body */
-    if (lsame_(uplo, "U")) {
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    i__2 = min(j,*m);
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
-/* L10: */
-	    }
-/* L20: */
-	}
-    } else if (lsame_(uplo, "L")) {
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    i__2 = *m;
-	    for (i__ = j; i__ <= i__2; ++i__) {
-		b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
-/* L30: */
-	    }
-/* L40: */
-	}
-    } else {
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    i__2 = *m;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
-/* L50: */
-	    }
-/* L60: */
-	}
-    }
-    return 0;
-
-/*     End of DLACPY */
-
-} /* dlacpy_ */

3rdparty/lapack/dlae2.c

@@ -1,142 +0,0 @@
-/* dlae2.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__, 
-	doublereal *rt1, doublereal *rt2)
-{
-    /* System generated locals */
-    doublereal d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    doublereal ab, df, tb, sm, rt, adf, acmn, acmx;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix */
-/*     [  A   B  ] */
-/*     [  B   C  ]. */
-/*  On return, RT1 is the eigenvalue of larger absolute value, and RT2 */
-/*  is the eigenvalue of smaller absolute value. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  A       (input) DOUBLE PRECISION */
-/*          The (1,1) element of the 2-by-2 matrix. */
-
-/*  B       (input) DOUBLE PRECISION */
-/*          The (1,2) and (2,1) elements of the 2-by-2 matrix. */
-
-/*  C       (input) DOUBLE PRECISION */
-/*          The (2,2) element of the 2-by-2 matrix. */
-
-/*  RT1     (output) DOUBLE PRECISION */
-/*          The eigenvalue of larger absolute value. */
-
-/*  RT2     (output) DOUBLE PRECISION */
-/*          The eigenvalue of smaller absolute value. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  RT1 is accurate to a few ulps barring over/underflow. */
-
-/*  RT2 may be inaccurate if there is massive cancellation in the */
-/*  determinant A*C-B*B; higher precision or correctly rounded or */
-/*  correctly truncated arithmetic would be needed to compute RT2 */
-/*  accurately in all cases. */
-
-/*  Overflow is possible only if RT1 is within a factor of 5 of overflow. */
-/*  Underflow is harmless if the input data is 0 or exceeds */
-/*     underflow_threshold / macheps. */
-
-/* ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Compute the eigenvalues */
-
-    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) {
-/* Computing 2nd power */
-	d__1 = ab / adf;
-	rt = adf * sqrt(d__1 * d__1 + 1.);
-    } else if (adf < ab) {
-/* Computing 2nd power */
-	d__1 = adf / ab;
-	rt = ab * sqrt(d__1 * d__1 + 1.);
-    } else {
-
-/*        Includes case AB=ADF=0 */
-
-	rt = ab * sqrt(2.);
-    }
-    if (sm < 0.) {
-	*rt1 = (sm - rt) * .5;
-
-/*        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 > 0.) {
-	*rt1 = (sm + rt) * .5;
-
-/*        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 = rt * .5;
-	*rt2 = rt * -.5;
-    }
-    return 0;
-
-/*     End of DLAE2 */
-
-} /* dlae2_ */

3rdparty/lapack/dlaebz.c

@@ -1,640 +0,0 @@
-/* dlaebz.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlaebz_(integer *ijob, integer *nitmax, integer *n, 
-	integer *mmax, integer *minp, integer *nbmin, doublereal *abstol, 
-	doublereal *reltol, doublereal *pivmin, doublereal *d__, doublereal *
-	e, doublereal *e2, integer *nval, doublereal *ab, doublereal *c__, 
-	integer *mout, integer *nab, doublereal *work, integer *iwork, 
-	integer *info)
-{
-    /* System generated locals */
-    integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4, 
-	    i__5, i__6;
-    doublereal d__1, d__2, d__3, d__4;
-
-    /* Local variables */
-    integer j, kf, ji, kl, jp, jit;
-    doublereal tmp1, tmp2;
-    integer itmp1, itmp2, kfnew, klnew;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAEBZ contains the iteration loops which compute and use the */
-/*  function N(w), which is the count of eigenvalues of a symmetric */
-/*  tridiagonal matrix T less than or equal to its argument  w.  It */
-/*  performs a choice of two types of loops: */
-
-/*  IJOB=1, followed by */
-/*  IJOB=2: It takes as input a list of intervals and returns a list of */
-/*          sufficiently small intervals whose union contains the same */
-/*          eigenvalues as the union of the original intervals. */
-/*          The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. */
-/*          The output interval (AB(j,1),AB(j,2)] will contain */
-/*          eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. */
-
-/*  IJOB=3: It performs a binary search in each input interval */
-/*          (AB(j,1),AB(j,2)] for a point  w(j)  such that */
-/*          N(w(j))=NVAL(j), and uses  C(j)  as the starting point of */
-/*          the search.  If such a w(j) is found, then on output */
-/*          AB(j,1)=AB(j,2)=w.  If no such w(j) is found, then on output */
-/*          (AB(j,1),AB(j,2)] will be a small interval containing the */
-/*          point where N(w) jumps through NVAL(j), unless that point */
-/*          lies outside the initial interval. */
-
-/*  Note that the intervals are in all cases half-open intervals, */
-/*  i.e., of the form  (a,b] , which includes  b  but not  a . */
-
-/*  To avoid underflow, the matrix should be scaled so that its largest */
-/*  element is no greater than  overflow**(1/2) * underflow**(1/4) */
-/*  in absolute value.  To assure the most accurate computation */
-/*  of small eigenvalues, the matrix should be scaled to be */
-/*  not much smaller than that, either. */
-
-/*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
-/*  Matrix", Report CS41, Computer Science Dept., Stanford */
-/*  University, July 21, 1966 */
-
-/*  Note: the arguments are, in general, *not* checked for unreasonable */
-/*  values. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  IJOB    (input) INTEGER */
-/*          Specifies what is to be done: */
-/*          = 1:  Compute NAB for the initial intervals. */
-/*          = 2:  Perform bisection iteration to find eigenvalues of T. */
-/*          = 3:  Perform bisection iteration to invert N(w), i.e., */
-/*                to find a point which has a specified number of */
-/*                eigenvalues of T to its left. */
-/*          Other values will cause DLAEBZ to return with INFO=-1. */
-
-/*  NITMAX  (input) INTEGER */
-/*          The maximum number of "levels" of bisection to be */
-/*          performed, i.e., an interval of width W will not be made */
-/*          smaller than 2^(-NITMAX) * W.  If not all intervals */
-/*          have converged after NITMAX iterations, then INFO is set */
-/*          to the number of non-converged intervals. */
-
-/*  N       (input) INTEGER */
-/*          The dimension n of the tridiagonal matrix T.  It must be at */
-/*          least 1. */
-
-/*  MMAX    (input) INTEGER */
-/*          The maximum number of intervals.  If more than MMAX intervals */
-/*          are generated, then DLAEBZ will quit with INFO=MMAX+1. */
-
-/*  MINP    (input) INTEGER */
-/*          The initial number of intervals.  It may not be greater than */
-/*          MMAX. */
-
-/*  NBMIN   (input) INTEGER */
-/*          The smallest number of intervals that should be processed */
-/*          using a vector loop.  If zero, then only the scalar loop */
-/*          will be used. */
-
-/*  ABSTOL  (input) DOUBLE PRECISION */
-/*          The minimum (absolute) width of an interval.  When an */
-/*          interval is narrower than ABSTOL, or than RELTOL times the */
-/*          larger (in magnitude) endpoint, then it is considered to be */
-/*          sufficiently small, i.e., converged.  This must be at least */
-/*          zero. */
-
-/*  RELTOL  (input) DOUBLE PRECISION */
-/*          The minimum relative width of an interval.  When an interval */
-/*          is narrower than ABSTOL, or than RELTOL times the larger (in */
-/*          magnitude) endpoint, then it is considered to be */
-/*          sufficiently small, i.e., converged.  Note: this should */
-/*          always be at least radix*machine epsilon. */
-
-/*  PIVMIN  (input) DOUBLE PRECISION */
-/*          The minimum absolute value of a "pivot" in the Sturm */
-/*          sequence loop.  This *must* be at least  max |e(j)**2| * */
-/*          safe_min  and at least safe_min, where safe_min is at least */
-/*          the smallest number that can divide one without overflow. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The diagonal elements of the tridiagonal matrix T. */
-
-/*  E       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The offdiagonal elements of the tridiagonal matrix T in */
-/*          positions 1 through N-1.  E(N) is arbitrary. */
-
-/*  E2      (input) DOUBLE PRECISION array, dimension (N) */
-/*          The squares of the offdiagonal elements of the tridiagonal */
-/*          matrix T.  E2(N) is ignored. */
-
-/*  NVAL    (input/output) INTEGER array, dimension (MINP) */
-/*          If IJOB=1 or 2, not referenced. */
-/*          If IJOB=3, the desired values of N(w).  The elements of NVAL */
-/*          will be reordered to correspond with the intervals in AB. */
-/*          Thus, NVAL(j) on output will not, in general be the same as */
-/*          NVAL(j) on input, but it will correspond with the interval */
-/*          (AB(j,1),AB(j,2)] on output. */
-
-/*  AB      (input/output) DOUBLE PRECISION array, dimension (MMAX,2) */
-/*          The endpoints of the intervals.  AB(j,1) is  a(j), the left */
-/*          endpoint of the j-th interval, and AB(j,2) is b(j), the */
-/*          right endpoint of the j-th interval.  The input intervals */
-/*          will, in general, be modified, split, and reordered by the */
-/*          calculation. */
-
-/*  C       (input/output) DOUBLE PRECISION array, dimension (MMAX) */
-/*          If IJOB=1, ignored. */
-/*          If IJOB=2, workspace. */
-/*          If IJOB=3, then on input C(j) should be initialized to the */
-/*          first search point in the binary search. */
-
-/*  MOUT    (output) INTEGER */
-/*          If IJOB=1, the number of eigenvalues in the intervals. */
-/*          If IJOB=2 or 3, the number of intervals output. */
-/*          If IJOB=3, MOUT will equal MINP. */
-
-/*  NAB     (input/output) INTEGER array, dimension (MMAX,2) */
-/*          If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). */
-/*          If IJOB=2, then on input, NAB(i,j) should be set.  It must */
-/*             satisfy the condition: */
-/*             N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), */
-/*             which means that in interval i only eigenvalues */
-/*             NAB(i,1)+1,...,NAB(i,2) will be considered.  Usually, */
-/*             NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with */
-/*             IJOB=1. */
-/*             On output, NAB(i,j) will contain */
-/*             max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of */
-/*             the input interval that the output interval */
-/*             (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the */
-/*             the input values of NAB(k,1) and NAB(k,2). */
-/*          If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), */
-/*             unless N(w) > NVAL(i) for all search points  w , in which */
-/*             case NAB(i,1) will not be modified, i.e., the output */
-/*             value will be the same as the input value (modulo */
-/*             reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) */
-/*             for all search points  w , in which case NAB(i,2) will */
-/*             not be modified.  Normally, NAB should be set to some */
-/*             distinctive value(s) before DLAEBZ is called. */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (MMAX) */
-/*          Workspace. */
-
-/*  IWORK   (workspace) INTEGER array, dimension (MMAX) */
-/*          Workspace. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:       All intervals converged. */
-/*          = 1--MMAX: The last INFO intervals did not converge. */
-/*          = MMAX+1:  More than MMAX intervals were generated. */
-
-/*  Further Details */
-/*  =============== */
-
-/*      This routine is intended to be called only by other LAPACK */
-/*  routines, thus the interface is less user-friendly.  It is intended */
-/*  for two purposes: */
-
-/*  (a) finding eigenvalues.  In this case, DLAEBZ should have one or */
-/*      more initial intervals set up in AB, and DLAEBZ should be called */
-/*      with IJOB=1.  This sets up NAB, and also counts the eigenvalues. */
-/*      Intervals with no eigenvalues would usually be thrown out at */
-/*      this point.  Also, if not all the eigenvalues in an interval i */
-/*      are desired, NAB(i,1) can be increased or NAB(i,2) decreased. */
-/*      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest */
-/*      eigenvalue.  DLAEBZ is then called with IJOB=2 and MMAX */
-/*      no smaller than the value of MOUT returned by the call with */
-/*      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1 */
-/*      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the */
-/*      tolerance specified by ABSTOL and RELTOL. */
-
-/*  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). */
-/*      In this case, start with a Gershgorin interval  (a,b).  Set up */
-/*      AB to contain 2 search intervals, both initially (a,b).  One */
-/*      NVAL element should contain  f-1  and the other should contain  l */
-/*      , while C should contain a and b, resp.  NAB(i,1) should be -1 */
-/*      and NAB(i,2) should be N+1, to flag an error if the desired */
-/*      interval does not lie in (a,b).  DLAEBZ is then called with */
-/*      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals -- */
-/*      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while */
-/*      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r */
-/*      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and */
-/*      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and */
-/*      w(l-r)=...=w(l+k) are handled similarly. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Check for Errors */
-
-    /* Parameter adjustments */
-    nab_dim1 = *mmax;
-    nab_offset = 1 + nab_dim1;
-    nab -= nab_offset;
-    ab_dim1 = *mmax;
-    ab_offset = 1 + ab_dim1;
-    ab -= ab_offset;
-    --d__;
-    --e;
-    --e2;
-    --nval;
-    --c__;
-    --work;
-    --iwork;
-
-    /* Function Body */
-    *info = 0;
-    if (*ijob < 1 || *ijob > 3) {
-	*info = -1;
-	return 0;
-    }
-
-/*     Initialize NAB */
-
-    if (*ijob == 1) {
-
-/*        Compute the number of eigenvalues in the initial intervals. */
-
-	*mout = 0;
-/* DIR$ NOVECTOR */
-	i__1 = *minp;
-	for (ji = 1; ji <= i__1; ++ji) {
-	    for (jp = 1; jp <= 2; ++jp) {
-		tmp1 = d__[1] - ab[ji + jp * ab_dim1];
-		if (abs(tmp1) < *pivmin) {
-		    tmp1 = -(*pivmin);
-		}
-		nab[ji + jp * nab_dim1] = 0;
-		if (tmp1 <= 0.) {
-		    nab[ji + jp * nab_dim1] = 1;
-		}
-
-		i__2 = *n;
-		for (j = 2; j <= i__2; ++j) {
-		    tmp1 = d__[j] - e2[j - 1] / tmp1 - ab[ji + jp * ab_dim1];
-		    if (abs(tmp1) < *pivmin) {
-			tmp1 = -(*pivmin);
-		    }
-		    if (tmp1 <= 0.) {
-			++nab[ji + jp * nab_dim1];
-		    }
-/* L10: */
-		}
-/* L20: */
-	    }
-	    *mout = *mout + nab[ji + (nab_dim1 << 1)] - nab[ji + nab_dim1];
-/* L30: */
-	}
-	return 0;
-    }
-
-/*     Initialize for loop */
-
-/*     KF and KL have the following meaning: */
-/*        Intervals 1,...,KF-1 have converged. */
-/*        Intervals KF,...,KL  still need to be refined. */
-
-    kf = 1;
-    kl = *minp;
-
-/*     If IJOB=2, initialize C. */
-/*     If IJOB=3, use the user-supplied starting point. */
-
-    if (*ijob == 2) {
-	i__1 = *minp;
-	for (ji = 1; ji <= i__1; ++ji) {
-	    c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5;
-/* L40: */
-	}
-    }
-
-/*     Iteration loop */
-
-    i__1 = *nitmax;
-    for (jit = 1; jit <= i__1; ++jit) {
-
-/*        Loop over intervals */
-
-	if (kl - kf + 1 >= *nbmin && *nbmin > 0) {
-
-/*           Begin of Parallel Version of the loop */
-
-	    i__2 = kl;
-	    for (ji = kf; ji <= i__2; ++ji) {
-
-/*              Compute N(c), the number of eigenvalues less than c */
-
-		work[ji] = d__[1] - c__[ji];
-		iwork[ji] = 0;
-		if (work[ji] <= *pivmin) {
-		    iwork[ji] = 1;
-/* Computing MIN */
-		    d__1 = work[ji], d__2 = -(*pivmin);
-		    work[ji] = min(d__1,d__2);
-		}
-
-		i__3 = *n;
-		for (j = 2; j <= i__3; ++j) {
-		    work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji];
-		    if (work[ji] <= *pivmin) {
-			++iwork[ji];
-/* Computing MIN */
-			d__1 = work[ji], d__2 = -(*pivmin);
-			work[ji] = min(d__1,d__2);
-		    }
-/* L50: */
-		}
-/* L60: */
-	    }
-
-	    if (*ijob <= 2) {
-
-/*              IJOB=2: Choose all intervals containing eigenvalues. */
-
-		klnew = kl;
-		i__2 = kl;
-		for (ji = kf; ji <= i__2; ++ji) {
-
-/*                 Insure that N(w) is monotone */
-
-/* Computing MIN */
-/* Computing MAX */
-		    i__5 = nab[ji + nab_dim1], i__6 = iwork[ji];
-		    i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,i__6);
-		    iwork[ji] = min(i__3,i__4);
-
-/*                 Update the Queue -- add intervals if both halves */
-/*                 contain eigenvalues. */
-
-		    if (iwork[ji] == nab[ji + (nab_dim1 << 1)]) {
-
-/*                    No eigenvalue in the upper interval: */
-/*                    just use the lower interval. */
-
-			ab[ji + (ab_dim1 << 1)] = c__[ji];
-
-		    } else if (iwork[ji] == nab[ji + nab_dim1]) {
-
-/*                    No eigenvalue in the lower interval: */
-/*                    just use the upper interval. */
-
-			ab[ji + ab_dim1] = c__[ji];
-		    } else {
-			++klnew;
-			if (klnew <= *mmax) {
-
-/*                       Eigenvalue in both intervals -- add upper to */
-/*                       queue. */
-
-			    ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 
-				    1)];
-			    nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 
-				    << 1)];
-			    ab[klnew + ab_dim1] = c__[ji];
-			    nab[klnew + nab_dim1] = iwork[ji];
-			    ab[ji + (ab_dim1 << 1)] = c__[ji];
-			    nab[ji + (nab_dim1 << 1)] = iwork[ji];
-			} else {
-			    *info = *mmax + 1;
-			}
-		    }
-/* L70: */
-		}
-		if (*info != 0) {
-		    return 0;
-		}
-		kl = klnew;
-	    } else {
-
-/*              IJOB=3: Binary search.  Keep only the interval containing */
-/*                      w   s.t. N(w) = NVAL */
-
-		i__2 = kl;
-		for (ji = kf; ji <= i__2; ++ji) {
-		    if (iwork[ji] <= nval[ji]) {
-			ab[ji + ab_dim1] = c__[ji];
-			nab[ji + nab_dim1] = iwork[ji];
-		    }
-		    if (iwork[ji] >= nval[ji]) {
-			ab[ji + (ab_dim1 << 1)] = c__[ji];
-			nab[ji + (nab_dim1 << 1)] = iwork[ji];
-		    }
-/* L80: */
-		}
-	    }
-
-	} else {
-
-/*           End of Parallel Version of the loop */
-
-/*           Begin of Serial Version of the loop */
-
-	    klnew = kl;
-	    i__2 = kl;
-	    for (ji = kf; ji <= i__2; ++ji) {
-
-/*              Compute N(w), the number of eigenvalues less than w */
-
-		tmp1 = c__[ji];
-		tmp2 = d__[1] - tmp1;
-		itmp1 = 0;
-		if (tmp2 <= *pivmin) {
-		    itmp1 = 1;
-/* Computing MIN */
-		    d__1 = tmp2, d__2 = -(*pivmin);
-		    tmp2 = min(d__1,d__2);
-		}
-
-/*              A series of compiler directives to defeat vectorization */
-/*              for the next loop */
-
-/* $PL$ CMCHAR=' ' */
-/* DIR$          NEXTSCALAR */
-/* $DIR          SCALAR */
-/* DIR$          NEXT SCALAR */
-/* VD$L          NOVECTOR */
-/* DEC$          NOVECTOR */
-/* VD$           NOVECTOR */
-/* VDIR          NOVECTOR */
-/* VOCL          LOOP,SCALAR */
-/* IBM           PREFER SCALAR */
-/* $PL$ CMCHAR='*' */
-
-		i__3 = *n;
-		for (j = 2; j <= i__3; ++j) {
-		    tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1;
-		    if (tmp2 <= *pivmin) {
-			++itmp1;
-/* Computing MIN */
-			d__1 = tmp2, d__2 = -(*pivmin);
-			tmp2 = min(d__1,d__2);
-		    }
-/* L90: */
-		}
-
-		if (*ijob <= 2) {
-
-/*                 IJOB=2: Choose all intervals containing eigenvalues. */
-
-/*                 Insure that N(w) is monotone */
-
-/* Computing MIN */
-/* Computing MAX */
-		    i__5 = nab[ji + nab_dim1];
-		    i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,itmp1);
-		    itmp1 = min(i__3,i__4);
-
-/*                 Update the Queue -- add intervals if both halves */
-/*                 contain eigenvalues. */
-
-		    if (itmp1 == nab[ji + (nab_dim1 << 1)]) {
-
-/*                    No eigenvalue in the upper interval: */
-/*                    just use the lower interval. */
-
-			ab[ji + (ab_dim1 << 1)] = tmp1;
-
-		    } else if (itmp1 == nab[ji + nab_dim1]) {
-
-/*                    No eigenvalue in the lower interval: */
-/*                    just use the upper interval. */
-
-			ab[ji + ab_dim1] = tmp1;
-		    } else if (klnew < *mmax) {
-
-/*                    Eigenvalue in both intervals -- add upper to queue. */
-
-			++klnew;
-			ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 1)];
-			nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 << 
-				1)];
-			ab[klnew + ab_dim1] = tmp1;
-			nab[klnew + nab_dim1] = itmp1;
-			ab[ji + (ab_dim1 << 1)] = tmp1;
-			nab[ji + (nab_dim1 << 1)] = itmp1;
-		    } else {
-			*info = *mmax + 1;
-			return 0;
-		    }
-		} else {
-
-/*                 IJOB=3: Binary search.  Keep only the interval */
-/*                         containing  w  s.t. N(w) = NVAL */
-
-		    if (itmp1 <= nval[ji]) {
-			ab[ji + ab_dim1] = tmp1;
-			nab[ji + nab_dim1] = itmp1;
-		    }
-		    if (itmp1 >= nval[ji]) {
-			ab[ji + (ab_dim1 << 1)] = tmp1;
-			nab[ji + (nab_dim1 << 1)] = itmp1;
-		    }
-		}
-/* L100: */
-	    }
-	    kl = klnew;
-
-/*           End of Serial Version of the loop */
-
-	}
-
-/*        Check for convergence */
-
-	kfnew = kf;
-	i__2 = kl;
-	for (ji = kf; ji <= i__2; ++ji) {
-	    tmp1 = (d__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], abs(
-		    d__1));
-/* Computing MAX */
-	    d__3 = (d__1 = ab[ji + (ab_dim1 << 1)], abs(d__1)), d__4 = (d__2 =
-		     ab[ji + ab_dim1], abs(d__2));
-	    tmp2 = max(d__3,d__4);
-/* Computing MAX */
-	    d__1 = max(*abstol,*pivmin), d__2 = *reltol * tmp2;
-	    if (tmp1 < max(d__1,d__2) || nab[ji + nab_dim1] >= nab[ji + (
-		    nab_dim1 << 1)]) {
-
-/*              Converged -- Swap with position KFNEW, */
-/*                           then increment KFNEW */
-
-		if (ji > kfnew) {
-		    tmp1 = ab[ji + ab_dim1];
-		    tmp2 = ab[ji + (ab_dim1 << 1)];
-		    itmp1 = nab[ji + nab_dim1];
-		    itmp2 = nab[ji + (nab_dim1 << 1)];
-		    ab[ji + ab_dim1] = ab[kfnew + ab_dim1];
-		    ab[ji + (ab_dim1 << 1)] = ab[kfnew + (ab_dim1 << 1)];
-		    nab[ji + nab_dim1] = nab[kfnew + nab_dim1];
-		    nab[ji + (nab_dim1 << 1)] = nab[kfnew + (nab_dim1 << 1)];
-		    ab[kfnew + ab_dim1] = tmp1;
-		    ab[kfnew + (ab_dim1 << 1)] = tmp2;
-		    nab[kfnew + nab_dim1] = itmp1;
-		    nab[kfnew + (nab_dim1 << 1)] = itmp2;
-		    if (*ijob == 3) {
-			itmp1 = nval[ji];
-			nval[ji] = nval[kfnew];
-			nval[kfnew] = itmp1;
-		    }
-		}
-		++kfnew;
-	    }
-/* L110: */
-	}
-	kf = kfnew;
-
-/*        Choose Midpoints */
-
-	i__2 = kl;
-	for (ji = kf; ji <= i__2; ++ji) {
-	    c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5;
-/* L120: */
-	}
-
-/*        If no more intervals to refine, quit. */
-
-	if (kf > kl) {
-	    goto L140;
-	}
-/* L130: */
-    }
-
-/*     Converged */
-
-L140:
-/* Computing MAX */
-    i__1 = kl + 1 - kf;
-    *info = max(i__1,0);
-    *mout = kl;
-
-    return 0;
-
-/*     End of DLAEBZ */
-
-} /* dlaebz_ */

3rdparty/lapack/dlaed0.c

@@ -1,440 +0,0 @@
-/* dlaed0.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__9 = 9;
-static integer c__0 = 0;
-static integer c__2 = 2;
-static doublereal c_b23 = 1.;
-static doublereal c_b24 = 0.;
-static integer c__1 = 1;
-
-/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n, 
-	doublereal *d__, doublereal *e, doublereal *q, integer *ldq, 
-	doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork, 
-	integer *info)
-{
-    /* System generated locals */
-    integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double log(doublereal);
-    integer pow_ii(integer *, integer *);
-
-    /* Local variables */
-    integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2;
-    doublereal temp;
-    integer curr;
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *);
-    integer iperm;
-    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *);
-    integer indxq, iwrem;
-    extern /* Subroutine */ int dlaed1_(integer *, doublereal *, doublereal *, 
-	     integer *, integer *, doublereal *, integer *, doublereal *, 
-	    integer *, integer *);
-    integer iqptr;
-    extern /* Subroutine */ int dlaed7_(integer *, integer *, integer *, 
-	    integer *, integer *, integer *, doublereal *, doublereal *, 
-	    integer *, integer *, doublereal *, integer *, doublereal *, 
-	    integer *, integer *, integer *, integer *, integer *, doublereal 
-	    *, doublereal *, integer *, integer *);
-    integer tlvls;
-    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, integer *);
-    integer igivcl;
-    extern /* Subroutine */ int xerbla_(char *, integer *);
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    integer igivnm, submat, curprb, subpbs, igivpt;
-    extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, 
-	    doublereal *, doublereal *, integer *, doublereal *, integer *);
-    integer curlvl, matsiz, iprmpt, smlsiz;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAED0 computes all eigenvalues and corresponding eigenvectors of a */
-/*  symmetric tridiagonal matrix using the divide and conquer method. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  ICOMPQ  (input) INTEGER */
-/*          = 0:  Compute eigenvalues only. */
-/*          = 1:  Compute eigenvectors of original dense symmetric matrix */
-/*                also.  On entry, Q contains the orthogonal matrix used */
-/*                to reduce the original matrix to tridiagonal form. */
-/*          = 2:  Compute eigenvalues and eigenvectors of tridiagonal */
-/*                matrix. */
-
-/*  QSIZ   (input) INTEGER */
-/*         The dimension of the orthogonal matrix used to reduce */
-/*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1. */
-
-/*  N      (input) INTEGER */
-/*         The dimension of the symmetric tridiagonal matrix.  N >= 0. */
-
-/*  D      (input/output) DOUBLE PRECISION array, dimension (N) */
-/*         On entry, the main diagonal of the tridiagonal matrix. */
-/*         On exit, its eigenvalues. */
-
-/*  E      (input) DOUBLE PRECISION array, dimension (N-1) */
-/*         The off-diagonal elements of the tridiagonal matrix. */
-/*         On exit, E has been destroyed. */
-
-/*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
-/*         On entry, Q must contain an N-by-N orthogonal matrix. */
-/*         If ICOMPQ = 0    Q is not referenced. */
-/*         If ICOMPQ = 1    On entry, Q is a subset of the columns of the */
-/*                          orthogonal matrix used to reduce the full */
-/*                          matrix to tridiagonal form corresponding to */
-/*                          the subset of the full matrix which is being */
-/*                          decomposed at this time. */
-/*         If ICOMPQ = 2    On entry, Q will be the identity matrix. */
-/*                          On exit, Q contains the eigenvectors of the */
-/*                          tridiagonal matrix. */
-
-/*  LDQ    (input) INTEGER */
-/*         The leading dimension of the array Q.  If eigenvectors are */
-/*         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1. */
-
-/*  QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N) */
-/*         Referenced only when ICOMPQ = 1.  Used to store parts of */
-/*         the eigenvector matrix when the updating matrix multiplies */
-/*         take place. */
-
-/*  LDQS   (input) INTEGER */
-/*         The leading dimension of the array QSTORE.  If ICOMPQ = 1, */
-/*         then  LDQS >= max(1,N).  In any case,  LDQS >= 1. */
-
-/*  WORK   (workspace) DOUBLE PRECISION array, */
-/*         If ICOMPQ = 0 or 1, the dimension of WORK must be at least */
-/*                     1 + 3*N + 2*N*lg N + 2*N**2 */
-/*                     ( lg( N ) = smallest integer k */
-/*                                 such that 2^k >= N ) */
-/*         If ICOMPQ = 2, the dimension of WORK must be at least */
-/*                     4*N + N**2. */
-
-/*  IWORK  (workspace) INTEGER array, */
-/*         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least */
-/*                        6 + 6*N + 5*N*lg N. */
-/*                        ( lg( N ) = smallest integer k */
-/*                                    such that 2^k >= N ) */
-/*         If ICOMPQ = 2, the dimension of IWORK must be at least */
-/*                        3 + 5*N. */
-
-/*  INFO   (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-/*          > 0:  The algorithm failed to compute an eigenvalue while */
-/*                working on the submatrix lying in rows and columns */
-/*                INFO/(N+1) through mod(INFO,N+1). */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Jeff Rutter, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    --e;
-    q_dim1 = *ldq;
-    q_offset = 1 + q_dim1;
-    q -= q_offset;
-    qstore_dim1 = *ldqs;
-    qstore_offset = 1 + qstore_dim1;
-    qstore -= qstore_offset;
-    --work;
-    --iwork;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*icompq < 0 || *icompq > 2) {
-	*info = -1;
-    } else if (*icompq == 1 && *qsiz < max(0,*n)) {
-	*info = -2;
-    } else if (*n < 0) {
-	*info = -3;
-    } else if (*ldq < max(1,*n)) {
-	*info = -7;
-    } else if (*ldqs < max(1,*n)) {
-	*info = -9;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAED0", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0) {
-	return 0;
-    }
-
-    smlsiz = ilaenv_(&c__9, "DLAED0", " ", &c__0, &c__0, &c__0, &c__0);
-
-/*     Determine the size and placement of the submatrices, and save in */
-/*     the leading elements of IWORK. */
-
-    iwork[1] = *n;
-    subpbs = 1;
-    tlvls = 0;
-L10:
-    if (iwork[subpbs] > smlsiz) {
-	for (j = subpbs; j >= 1; --j) {
-	    iwork[j * 2] = (iwork[j] + 1) / 2;
-	    iwork[(j << 1) - 1] = iwork[j] / 2;
-/* L20: */
-	}
-	++tlvls;
-	subpbs <<= 1;
-	goto L10;
-    }
-    i__1 = subpbs;
-    for (j = 2; j <= i__1; ++j) {
-	iwork[j] += iwork[j - 1];
-/* L30: */
-    }
-
-/*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */
-/*     using rank-1 modifications (cuts). */
-
-    spm1 = subpbs - 1;
-    i__1 = spm1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	submat = iwork[i__] + 1;
-	smm1 = submat - 1;
-	d__[smm1] -= (d__1 = e[smm1], abs(d__1));
-	d__[submat] -= (d__1 = e[smm1], abs(d__1));
-/* L40: */
-    }
-
-    indxq = (*n << 2) + 3;
-    if (*icompq != 2) {
-
-/*        Set up workspaces for eigenvalues only/accumulate new vectors */
-/*        routine */
-
-	temp = log((doublereal) (*n)) / log(2.);
-	lgn = (integer) temp;
-	if (pow_ii(&c__2, &lgn) < *n) {
-	    ++lgn;
-	}
-	if (pow_ii(&c__2, &lgn) < *n) {
-	    ++lgn;
-	}
-	iprmpt = indxq + *n + 1;
-	iperm = iprmpt + *n * lgn;
-	iqptr = iperm + *n * lgn;
-	igivpt = iqptr + *n + 2;
-	igivcl = igivpt + *n * lgn;
-
-	igivnm = 1;
-	iq = igivnm + (*n << 1) * lgn;
-/* Computing 2nd power */
-	i__1 = *n;
-	iwrem = iq + i__1 * i__1 + 1;
-
-/*        Initialize pointers */
-
-	i__1 = subpbs;
-	for (i__ = 0; i__ <= i__1; ++i__) {
-	    iwork[iprmpt + i__] = 1;
-	    iwork[igivpt + i__] = 1;
-/* L50: */
-	}
-	iwork[iqptr] = 1;
-    }
-
-/*     Solve each submatrix eigenproblem at the bottom of the divide and */
-/*     conquer tree. */
-
-    curr = 0;
-    i__1 = spm1;
-    for (i__ = 0; i__ <= i__1; ++i__) {
-	if (i__ == 0) {
-	    submat = 1;
-	    matsiz = iwork[1];
-	} else {
-	    submat = iwork[i__] + 1;
-	    matsiz = iwork[i__ + 1] - iwork[i__];
-	}
-	if (*icompq == 2) {
-	    dsteqr_("I", &matsiz, &d__[submat], &e[submat], &q[submat + 
-		    submat * q_dim1], ldq, &work[1], info);
-	    if (*info != 0) {
-		goto L130;
-	    }
-	} else {
-	    dsteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + 
-		    iwork[iqptr + curr]], &matsiz, &work[1], info);
-	    if (*info != 0) {
-		goto L130;
-	    }
-	    if (*icompq == 1) {
-		dgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * 
-			q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]], 
-			 &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1], 
-			ldqs);
-	    }
-/* Computing 2nd power */
-	    i__2 = matsiz;
-	    iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
-	    ++curr;
-	}
-	k = 1;
-	i__2 = iwork[i__ + 1];
-	for (j = submat; j <= i__2; ++j) {
-	    iwork[indxq + j] = k;
-	    ++k;
-/* L60: */
-	}
-/* L70: */
-    }
-
-/*     Successively merge eigensystems of adjacent submatrices */
-/*     into eigensystem for the corresponding larger matrix. */
-
-/*     while ( SUBPBS > 1 ) */
-
-    curlvl = 1;
-L80:
-    if (subpbs > 1) {
-	spm2 = subpbs - 2;
-	i__1 = spm2;
-	for (i__ = 0; i__ <= i__1; i__ += 2) {
-	    if (i__ == 0) {
-		submat = 1;
-		matsiz = iwork[2];
-		msd2 = iwork[1];
-		curprb = 0;
-	    } else {
-		submat = iwork[i__] + 1;
-		matsiz = iwork[i__ + 2] - iwork[i__];
-		msd2 = matsiz / 2;
-		++curprb;
-	    }
-
-/*     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */
-/*     into an eigensystem of size MATSIZ. */
-/*     DLAED1 is used only for the full eigensystem of a tridiagonal */
-/*     matrix. */
-/*     DLAED7 handles the cases in which eigenvalues only or eigenvalues */
-/*     and eigenvectors of a full symmetric matrix (which was reduced to */
-/*     tridiagonal form) are desired. */
-
-	    if (*icompq == 2) {
-		dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], 
-			ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], &
-			msd2, &work[1], &iwork[subpbs + 1], info);
-	    } else {
-		dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[
-			submat], &qstore[submat * qstore_dim1 + 1], ldqs, &
-			iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &
-			work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm]
-, &iwork[igivpt], &iwork[igivcl], &work[igivnm], &
-			work[iwrem], &iwork[subpbs + 1], info);
-	    }
-	    if (*info != 0) {
-		goto L130;
-	    }
-	    iwork[i__ / 2 + 1] = iwork[i__ + 2];
-/* L90: */
-	}
-	subpbs /= 2;
-	++curlvl;
-	goto L80;
-    }
-
-/*     end while */
-
-/*     Re-merge the eigenvalues/vectors which were deflated at the final */
-/*     merge step. */
-
-    if (*icompq == 1) {
-	i__1 = *n;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    j = iwork[indxq + i__];
-	    work[i__] = d__[j];
-	    dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 
-		    + 1], &c__1);
-/* L100: */
-	}
-	dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
-    } else if (*icompq == 2) {
-	i__1 = *n;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    j = iwork[indxq + i__];
-	    work[i__] = d__[j];
-	    dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1);
-/* L110: */
-	}
-	dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
-	dlacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq);
-    } else {
-	i__1 = *n;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    j = iwork[indxq + i__];
-	    work[i__] = d__[j];
-/* L120: */
-	}
-	dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
-    }
-    goto L140;
-
-L130:
-    *info = submat * (*n + 1) + submat + matsiz - 1;
-
-L140:
-    return 0;
-
-/*     End of DLAED0 */
-
-} /* dlaed0_ */

3rdparty/lapack/dlaed1.c

@@ -1,249 +0,0 @@
-/* dlaed1.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c_n1 = -1;
-
-/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q, 
-	integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, 
-	doublereal *work, integer *iwork, integer *info)
-{
-    /* System generated locals */
-    integer q_dim1, q_offset, i__1, i__2;
-
-    /* Local variables */
-    integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc;
-    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *);
-    integer indxp;
-    extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *, 
-	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, integer *, 
-	     integer *, integer *, integer *, integer *), dlaed3_(integer *, 
-	    integer *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *, doublereal *, doublereal *, integer *, integer *, 
-	    doublereal *, doublereal *, integer *);
-    integer idlmda;
-    extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, 
-	    integer *, integer *, integer *), xerbla_(char *, integer *);
-    integer coltyp;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAED1 computes the updated eigensystem of a diagonal */
-/*  matrix after modification by a rank-one symmetric matrix.  This */
-/*  routine is used only for the eigenproblem which requires all */
-/*  eigenvalues and eigenvectors of a tridiagonal matrix.  DLAED7 handles */
-/*  the case in which eigenvalues only or eigenvalues and eigenvectors */
-/*  of a full symmetric matrix (which was reduced to tridiagonal form) */
-/*  are desired. */
-
-/*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
-
-/*     where Z = Q'u, u is a vector of length N with ones in the */
-/*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
-
-/*     The eigenvectors of the original matrix are stored in Q, and the */
-/*     eigenvalues are in D.  The algorithm consists of three stages: */
-
-/*        The first stage consists of deflating the size of the problem */
-/*        when there are multiple eigenvalues or if there is a zero in */
-/*        the Z vector.  For each such occurence the dimension of the */
-/*        secular equation problem is reduced by one.  This stage is */
-/*        performed by the routine DLAED2. */
-
-/*        The second stage consists of calculating the updated */
-/*        eigenvalues. This is done by finding the roots of the secular */
-/*        equation via the routine DLAED4 (as called by DLAED3). */
-/*        This routine also calculates the eigenvectors of the current */
-/*        problem. */
-
-/*        The final stage consists of computing the updated eigenvectors */
-/*        directly using the updated eigenvalues.  The eigenvectors for */
-/*        the current problem are multiplied with the eigenvectors from */
-/*        the overall problem. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N      (input) INTEGER */
-/*         The dimension of the symmetric tridiagonal matrix.  N >= 0. */
-
-/*  D      (input/output) DOUBLE PRECISION array, dimension (N) */
-/*         On entry, the eigenvalues of the rank-1-perturbed matrix. */
-/*         On exit, the eigenvalues of the repaired matrix. */
-
-/*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
-/*         On entry, the eigenvectors of the rank-1-perturbed matrix. */
-/*         On exit, the eigenvectors of the repaired tridiagonal matrix. */
-
-/*  LDQ    (input) INTEGER */
-/*         The leading dimension of the array Q.  LDQ >= max(1,N). */
-
-/*  INDXQ  (input/output) INTEGER array, dimension (N) */
-/*         On entry, the permutation which separately sorts the two */
-/*         subproblems in D into ascending order. */
-/*         On exit, the permutation which will reintegrate the */
-/*         subproblems back into sorted order, */
-/*         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. */
-
-/*  RHO    (input) DOUBLE PRECISION */
-/*         The subdiagonal entry used to create the rank-1 modification. */
-
-/*  CUTPNT (input) INTEGER */
-/*         The location of the last eigenvalue in the leading sub-matrix. */
-/*         min(1,N) <= CUTPNT <= N/2. */
-
-/*  WORK   (workspace) DOUBLE PRECISION array, dimension (4*N + N**2) */
-
-/*  IWORK  (workspace) INTEGER array, dimension (4*N) */
-
-/*  INFO   (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-/*          > 0:  if INFO = 1, an eigenvalue did not converge */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Jeff Rutter, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-/*  Modified by Francoise Tisseur, University of Tennessee. */
-
-/*  ===================================================================== */
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    q_dim1 = *ldq;
-    q_offset = 1 + q_dim1;
-    q -= q_offset;
-    --indxq;
-    --work;
-    --iwork;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*n < 0) {
-	*info = -1;
-    } else if (*ldq < max(1,*n)) {
-	*info = -4;
-    } else /* if(complicated condition) */ {
-/* Computing MIN */
-	i__1 = 1, i__2 = *n / 2;
-	if (min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) {
-	    *info = -7;
-	}
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAED1", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0) {
-	return 0;
-    }
-
-/*     The following values are integer pointers which indicate */
-/*     the portion of the workspace */
-/*     used by a particular array in DLAED2 and DLAED3. */
-
-    iz = 1;
-    idlmda = iz + *n;
-    iw = idlmda + *n;
-    iq2 = iw + *n;
-
-    indx = 1;
-    indxc = indx + *n;
-    coltyp = indxc + *n;
-    indxp = coltyp + *n;
-
-
-/*     Form the z-vector which consists of the last row of Q_1 and the */
-/*     first row of Q_2. */
-
-    dcopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1);
-    zpp1 = *cutpnt + 1;
-    i__1 = *n - *cutpnt;
-    dcopy_(&i__1, &q[zpp1 + zpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1);
-
-/*     Deflate eigenvalues. */
-
-    dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[
-	    iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[
-	    indxc], &iwork[indxp], &iwork[coltyp], info);
-
-    if (*info != 0) {
-	goto L20;
-    }
-
-/*     Solve Secular Equation. */
-
-    if (k != 0) {
-	is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp + 
-		1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2;
-	dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], 
-		 &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[
-		is], info);
-	if (*info != 0) {
-	    goto L20;
-	}
-
-/*     Prepare the INDXQ sorting permutation. */
-
-	n1 = k;
-	n2 = *n - k;
-	dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
-    } else {
-	i__1 = *n;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    indxq[i__] = i__;
-/* L10: */
-	}
-    }
-
-L20:
-    return 0;
-
-/*     End of DLAED1 */
-
-} /* dlaed1_ */

3rdparty/lapack/dlaed2.c

@@ -1,532 +0,0 @@
-/* dlaed2.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static doublereal c_b3 = -1.;
-static integer c__1 = 1;
-
-/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal *
-	d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, 
-	doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2, 
-	integer *indx, integer *indxc, integer *indxp, integer *coltyp, 
-	integer *info)
-{
-    /* System generated locals */
-    integer q_dim1, q_offset, i__1, i__2;
-    doublereal d__1, d__2, d__3, d__4;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    doublereal c__;
-    integer i__, j;
-    doublereal s, t;
-    integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1;
-    doublereal eps, tau, tol;
-    integer psm[4], imax, jmax;
-    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *);
-    integer ctot[4];
-    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
-	    integer *), dcopy_(integer *, doublereal *, integer *, doublereal 
-	    *, integer *);
-    extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
-    extern integer idamax_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, 
-	    integer *, integer *, integer *), dlacpy_(char *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAED2 merges the two sets of eigenvalues together into a single */
-/*  sorted set.  Then it tries to deflate the size of the problem. */
-/*  There are two ways in which deflation can occur:  when two or more */
-/*  eigenvalues are close together or if there is a tiny entry in the */
-/*  Z vector.  For each such occurrence the order of the related secular */
-/*  equation problem is reduced by one. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  K      (output) INTEGER */
-/*         The number of non-deflated eigenvalues, and the order of the */
-/*         related secular equation. 0 <= K <=N. */
-
-/*  N      (input) INTEGER */
-/*         The dimension of the symmetric tridiagonal matrix.  N >= 0. */
-
-/*  N1     (input) INTEGER */
-/*         The location of the last eigenvalue in the leading sub-matrix. */
-/*         min(1,N) <= N1 <= N/2. */
-
-/*  D      (input/output) DOUBLE PRECISION array, dimension (N) */
-/*         On entry, D contains the eigenvalues of the two submatrices to */
-/*         be combined. */
-/*         On exit, D contains the trailing (N-K) updated eigenvalues */
-/*         (those which were deflated) sorted into increasing order. */
-
-/*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
-/*         On entry, Q contains the eigenvectors of two submatrices in */
-/*         the two square blocks with corners at (1,1), (N1,N1) */
-/*         and (N1+1, N1+1), (N,N). */
-/*         On exit, Q contains the trailing (N-K) updated eigenvectors */
-/*         (those which were deflated) in its last N-K columns. */
-
-/*  LDQ    (input) INTEGER */
-/*         The leading dimension of the array Q.  LDQ >= max(1,N). */
-
-/*  INDXQ  (input/output) INTEGER array, dimension (N) */
-/*         The permutation which separately sorts the two sub-problems */
-/*         in D into ascending order.  Note that elements in the second */
-/*         half of this permutation must first have N1 added to their */
-/*         values. Destroyed on exit. */
-
-/*  RHO    (input/output) DOUBLE PRECISION */
-/*         On entry, the off-diagonal element associated with the rank-1 */
-/*         cut which originally split the two submatrices which are now */
-/*         being recombined. */
-/*         On exit, RHO has been modified to the value required by */
-/*         DLAED3. */
-
-/*  Z      (input) DOUBLE PRECISION array, dimension (N) */
-/*         On entry, Z contains the updating vector (the last */
-/*         row of the first sub-eigenvector matrix and the first row of */
-/*         the second sub-eigenvector matrix). */
-/*         On exit, the contents of Z have been destroyed by the updating */
-/*         process. */
-
-/*  DLAMDA (output) DOUBLE PRECISION array, dimension (N) */
-/*         A copy of the first K eigenvalues which will be used by */
-/*         DLAED3 to form the secular equation. */
-
-/*  W      (output) DOUBLE PRECISION array, dimension (N) */
-/*         The first k values of the final deflation-altered z-vector */
-/*         which will be passed to DLAED3. */
-
-/*  Q2     (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) */
-/*         A copy of the first K eigenvectors which will be used by */
-/*         DLAED3 in a matrix multiply (DGEMM) to solve for the new */
-/*         eigenvectors. */
-
-/*  INDX   (workspace) INTEGER array, dimension (N) */
-/*         The permutation used to sort the contents of DLAMDA into */
-/*         ascending order. */
-
-/*  INDXC  (output) INTEGER array, dimension (N) */
-/*         The permutation used to arrange the columns of the deflated */
-/*         Q matrix into three groups:  the first group contains non-zero */
-/*         elements only at and above N1, the second contains */
-/*         non-zero elements only below N1, and the third is dense. */
-
-/*  INDXP  (workspace) INTEGER array, dimension (N) */
-/*         The permutation used to place deflated values of D at the end */
-/*         of the array.  INDXP(1:K) points to the nondeflated D-values */
-/*         and INDXP(K+1:N) points to the deflated eigenvalues. */
-
-/*  COLTYP (workspace/output) INTEGER array, dimension (N) */
-/*         During execution, a label which will indicate which of the */
-/*         following types a column in the Q2 matrix is: */
-/*         1 : non-zero in the upper half only; */
-/*         2 : dense; */
-/*         3 : non-zero in the lower half only; */
-/*         4 : deflated. */
-/*         On exit, COLTYP(i) is the number of columns of type i, */
-/*         for i=1 to 4 only. */
-
-/*  INFO   (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Jeff Rutter, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-/*  Modified by Francoise Tisseur, University of Tennessee. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Arrays .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    q_dim1 = *ldq;
-    q_offset = 1 + q_dim1;
-    q -= q_offset;
-    --indxq;
-    --z__;
-    --dlamda;
-    --w;
-    --q2;
-    --indx;
-    --indxc;
-    --indxp;
-    --coltyp;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*n < 0) {
-	*info = -2;
-    } else if (*ldq < max(1,*n)) {
-	*info = -6;
-    } else /* if(complicated condition) */ {
-/* Computing MIN */
-	i__1 = 1, i__2 = *n / 2;
-	if (min(i__1,i__2) > *n1 || *n / 2 < *n1) {
-	    *info = -3;
-	}
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAED2", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0) {
-	return 0;
-    }
-
-    n2 = *n - *n1;
-    n1p1 = *n1 + 1;
-
-    if (*rho < 0.) {
-	dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
-    }
-
-/*     Normalize z so that norm(z) = 1.  Since z is the concatenation of */
-/*     two normalized vectors, norm2(z) = sqrt(2). */
-
-    t = 1. / sqrt(2.);
-    dscal_(n, &t, &z__[1], &c__1);
-
-/*     RHO = ABS( norm(z)**2 * RHO ) */
-
-    *rho = (d__1 = *rho * 2., abs(d__1));
-
-/*     Sort the eigenvalues into increasing order */
-
-    i__1 = *n;
-    for (i__ = n1p1; i__ <= i__1; ++i__) {
-	indxq[i__] += *n1;
-/* L10: */
-    }
-
-/*     re-integrate the deflated parts from the last pass */
-
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dlamda[i__] = d__[indxq[i__]];
-/* L20: */
-    }
-    dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	indx[i__] = indxq[indxc[i__]];
-/* L30: */
-    }
-
-/*     Calculate the allowable deflation tolerance */
-
-    imax = idamax_(n, &z__[1], &c__1);
-    jmax = idamax_(n, &d__[1], &c__1);
-    eps = dlamch_("Epsilon");
-/* Computing MAX */
-    d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2))
-	    ;
-    tol = eps * 8. * max(d__3,d__4);
-
-/*     If the rank-1 modifier is small enough, no more needs to be done */
-/*     except to reorganize Q so that its columns correspond with the */
-/*     elements in D. */
-
-    if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
-	*k = 0;
-	iq2 = 1;
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    i__ = indx[j];
-	    dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
-	    dlamda[j] = d__[i__];
-	    iq2 += *n;
-/* L40: */
-	}
-	dlacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq);
-	dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
-	goto L190;
-    }
-
-/*     If there are multiple eigenvalues then the problem deflates.  Here */
-/*     the number of equal eigenvalues are found.  As each equal */
-/*     eigenvalue is found, an elementary reflector is computed to rotate */
-/*     the corresponding eigensubspace so that the corresponding */
-/*     components of Z are zero in this new basis. */
-
-    i__1 = *n1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	coltyp[i__] = 1;
-/* L50: */
-    }
-    i__1 = *n;
-    for (i__ = n1p1; i__ <= i__1; ++i__) {
-	coltyp[i__] = 3;
-/* L60: */
-    }
-
-
-    *k = 0;
-    k2 = *n + 1;
-    i__1 = *n;
-    for (j = 1; j <= i__1; ++j) {
-	nj = indx[j];
-	if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
-
-/*           Deflate due to small z component. */
-
-	    --k2;
-	    coltyp[nj] = 4;
-	    indxp[k2] = nj;
-	    if (j == *n) {
-		goto L100;
-	    }
-	} else {
-	    pj = nj;
-	    goto L80;
-	}
-/* L70: */
-    }
-L80:
-    ++j;
-    nj = indx[j];
-    if (j > *n) {
-	goto L100;
-    }
-    if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
-
-/*        Deflate due to small z component. */
-
-	--k2;
-	coltyp[nj] = 4;
-	indxp[k2] = nj;
-    } else {
-
-/*        Check if eigenvalues are close enough to allow deflation. */
-
-	s = z__[pj];
-	c__ = z__[nj];
-
-/*        Find sqrt(a**2+b**2) without overflow or */
-/*        destructive underflow. */
-
-	tau = dlapy2_(&c__, &s);
-	t = d__[nj] - d__[pj];
-	c__ /= tau;
-	s = -s / tau;
-	if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
-
-/*           Deflation is possible. */
-
-	    z__[nj] = tau;
-	    z__[pj] = 0.;
-	    if (coltyp[nj] != coltyp[pj]) {
-		coltyp[nj] = 2;
-	    }
-	    coltyp[pj] = 4;
-	    drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &
-		    c__, &s);
-/* Computing 2nd power */
-	    d__1 = c__;
-/* Computing 2nd power */
-	    d__2 = s;
-	    t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
-/* Computing 2nd power */
-	    d__1 = s;
-/* Computing 2nd power */
-	    d__2 = c__;
-	    d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
-	    d__[pj] = t;
-	    --k2;
-	    i__ = 1;
-L90:
-	    if (k2 + i__ <= *n) {
-		if (d__[pj] < d__[indxp[k2 + i__]]) {
-		    indxp[k2 + i__ - 1] = indxp[k2 + i__];
-		    indxp[k2 + i__] = pj;
-		    ++i__;
-		    goto L90;
-		} else {
-		    indxp[k2 + i__ - 1] = pj;
-		}
-	    } else {
-		indxp[k2 + i__ - 1] = pj;
-	    }
-	    pj = nj;
-	} else {
-	    ++(*k);
-	    dlamda[*k] = d__[pj];
-	    w[*k] = z__[pj];
-	    indxp[*k] = pj;
-	    pj = nj;
-	}
-    }
-    goto L80;
-L100:
-
-/*     Record the last eigenvalue. */
-
-    ++(*k);
-    dlamda[*k] = d__[pj];
-    w[*k] = z__[pj];
-    indxp[*k] = pj;
-
-/*     Count up the total number of the various types of columns, then */
-/*     form a permutation which positions the four column types into */
-/*     four uniform groups (although one or more of these groups may be */
-/*     empty). */
-
-    for (j = 1; j <= 4; ++j) {
-	ctot[j - 1] = 0;
-/* L110: */
-    }
-    i__1 = *n;
-    for (j = 1; j <= i__1; ++j) {
-	ct = coltyp[j];
-	++ctot[ct - 1];
-/* L120: */
-    }
-
-/*     PSM(*) = Position in SubMatrix (of types 1 through 4) */
-
-    psm[0] = 1;
-    psm[1] = ctot[0] + 1;
-    psm[2] = psm[1] + ctot[1];
-    psm[3] = psm[2] + ctot[2];
-    *k = *n - ctot[3];
-
-/*     Fill out the INDXC array so that the permutation which it induces */
-/*     will place all type-1 columns first, all type-2 columns next, */
-/*     then all type-3's, and finally all type-4's. */
-
-    i__1 = *n;
-    for (j = 1; j <= i__1; ++j) {
-	js = indxp[j];
-	ct = coltyp[js];
-	indx[psm[ct - 1]] = js;
-	indxc[psm[ct - 1]] = j;
-	++psm[ct - 1];
-/* L130: */
-    }
-
-/*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
-/*     and Q2 respectively.  The eigenvalues/vectors which were not */
-/*     deflated go into the first K slots of DLAMDA and Q2 respectively, */
-/*     while those which were deflated go into the last N - K slots. */
-
-    i__ = 1;
-    iq1 = 1;
-    iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
-    i__1 = ctot[0];
-    for (j = 1; j <= i__1; ++j) {
-	js = indx[i__];
-	dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
-	z__[i__] = d__[js];
-	++i__;
-	iq1 += *n1;
-/* L140: */
-    }
-
-    i__1 = ctot[1];
-    for (j = 1; j <= i__1; ++j) {
-	js = indx[i__];
-	dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
-	dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
-	z__[i__] = d__[js];
-	++i__;
-	iq1 += *n1;
-	iq2 += n2;
-/* L150: */
-    }
-
-    i__1 = ctot[2];
-    for (j = 1; j <= i__1; ++j) {
-	js = indx[i__];
-	dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
-	z__[i__] = d__[js];
-	++i__;
-	iq2 += n2;
-/* L160: */
-    }
-
-    iq1 = iq2;
-    i__1 = ctot[3];
-    for (j = 1; j <= i__1; ++j) {
-	js = indx[i__];
-	dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
-	iq2 += *n;
-	z__[i__] = d__[js];
-	++i__;
-/* L170: */
-    }
-
-/*     The deflated eigenvalues and their corresponding vectors go back */
-/*     into the last N - K slots of D and Q respectively. */
-
-    dlacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq);
-    i__1 = *n - *k;
-    dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
-
-/*     Copy CTOT into COLTYP for referencing in DLAED3. */
-
-    for (j = 1; j <= 4; ++j) {
-	coltyp[j] = ctot[j - 1];
-/* L180: */
-    }
-
-L190:
-    return 0;
-
-/*     End of DLAED2 */
-
-} /* dlaed2_ */

3rdparty/lapack/dlaed3.c

@@ -1,338 +0,0 @@
-/* dlaed3.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static doublereal c_b22 = 1.;
-static doublereal c_b23 = 0.;
-
-/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal *
-	d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda, 
-	 doublereal *q2, integer *indx, integer *ctot, doublereal *w, 
-	doublereal *s, integer *info)
-{
-    /* System generated locals */
-    integer q_dim1, q_offset, i__1, i__2;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal), d_sign(doublereal *, doublereal *);
-
-    /* Local variables */
-    integer i__, j, n2, n12, ii, n23, iq2;
-    doublereal temp;
-    extern doublereal dnrm2_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *),
-	     dcopy_(integer *, doublereal *, integer *, doublereal *, integer 
-	    *), dlaed4_(integer *, integer *, doublereal *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *, integer *);
-    extern doublereal dlamc3_(doublereal *, doublereal *);
-    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, integer *), 
-	    dlaset_(char *, integer *, integer *, doublereal *, doublereal *, 
-	    doublereal *, integer *), xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAED3 finds the roots of the secular equation, as defined by the */
-/*  values in D, W, and RHO, between 1 and K.  It makes the */
-/*  appropriate calls to DLAED4 and then updates the eigenvectors by */
-/*  multiplying the matrix of eigenvectors of the pair of eigensystems */
-/*  being combined by the matrix of eigenvectors of the K-by-K system */
-/*  which is solved here. */
-
-/*  This code makes very mild assumptions about floating point */
-/*  arithmetic. It will work on machines with a guard digit in */
-/*  add/subtract, or on those binary machines without guard digits */
-/*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
-/*  It could conceivably fail on hexadecimal or decimal machines */
-/*  without guard digits, but we know of none. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  K       (input) INTEGER */
-/*          The number of terms in the rational function to be solved by */
-/*          DLAED4.  K >= 0. */
-
-/*  N       (input) INTEGER */
-/*          The number of rows and columns in the Q matrix. */
-/*          N >= K (deflation may result in N>K). */
-
-/*  N1      (input) INTEGER */
-/*          The location of the last eigenvalue in the leading submatrix. */
-/*          min(1,N) <= N1 <= N/2. */
-
-/*  D       (output) DOUBLE PRECISION array, dimension (N) */
-/*          D(I) contains the updated eigenvalues for */
-/*          1 <= I <= K. */
-
-/*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N) */
-/*          Initially the first K columns are used as workspace. */
-/*          On output the columns 1 to K contain */
-/*          the updated eigenvectors. */
-
-/*  LDQ     (input) INTEGER */
-/*          The leading dimension of the array Q.  LDQ >= max(1,N). */
-
-/*  RHO     (input) DOUBLE PRECISION */
-/*          The value of the parameter in the rank one update equation. */
-/*          RHO >= 0 required. */
-
-/*  DLAMDA  (input/output) DOUBLE PRECISION array, dimension (K) */
-/*          The first K elements of this array contain the old roots */
-/*          of the deflated updating problem.  These are the poles */
-/*          of the secular equation. May be changed on output by */
-/*          having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */
-/*          Cray-2, or Cray C-90, as described above. */
-
-/*  Q2      (input) DOUBLE PRECISION array, dimension (LDQ2, N) */
-/*          The first K columns of this matrix contain the non-deflated */
-/*          eigenvectors for the split problem. */
-
-/*  INDX    (input) INTEGER array, dimension (N) */
-/*          The permutation used to arrange the columns of the deflated */
-/*          Q matrix into three groups (see DLAED2). */
-/*          The rows of the eigenvectors found by DLAED4 must be likewise */
-/*          permuted before the matrix multiply can take place. */
-
-/*  CTOT    (input) INTEGER array, dimension (4) */
-/*          A count of the total number of the various types of columns */
-/*          in Q, as described in INDX.  The fourth column type is any */
-/*          column which has been deflated. */
-
-/*  W       (input/output) DOUBLE PRECISION array, dimension (K) */
-/*          The first K elements of this array contain the components */
-/*          of the deflation-adjusted updating vector. Destroyed on */
-/*          output. */
-
-/*  S       (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K */
-/*          Will contain the eigenvectors of the repaired matrix which */
-/*          will be multiplied by the previously accumulated eigenvectors */
-/*          to update the system. */
-
-/*  LDS     (input) INTEGER */
-/*          The leading dimension of S.  LDS >= max(1,K). */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-/*          > 0:  if INFO = 1, an eigenvalue did not converge */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Jeff Rutter, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-/*  Modified by Francoise Tisseur, University of Tennessee. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    q_dim1 = *ldq;
-    q_offset = 1 + q_dim1;
-    q -= q_offset;
-    --dlamda;
-    --q2;
-    --indx;
-    --ctot;
-    --w;
-    --s;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*k < 0) {
-	*info = -1;
-    } else if (*n < *k) {
-	*info = -2;
-    } else if (*ldq < max(1,*n)) {
-	*info = -6;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAED3", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*k == 0) {
-	return 0;
-    }
-
-/*     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
-/*     be computed with high relative accuracy (barring over/underflow). */
-/*     This is a problem on machines without a guard digit in */
-/*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
-/*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
-/*     which on any of these machines zeros out the bottommost */
-/*     bit of DLAMDA(I) if it is 1; this makes the subsequent */
-/*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
-/*     occurs. On binary machines with a guard digit (almost all */
-/*     machines) it does not change DLAMDA(I) at all. On hexadecimal */
-/*     and decimal machines with a guard digit, it slightly */
-/*     changes the bottommost bits of DLAMDA(I). It does not account */
-/*     for hexadecimal or decimal machines without guard digits */
-/*     (we know of none). We use a subroutine call to compute */
-/*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
-/*     this code. */
-
-    i__1 = *k;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
-/* L10: */
-    }
-
-    i__1 = *k;
-    for (j = 1; j <= i__1; ++j) {
-	dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], 
-		info);
-
-/*        If the zero finder fails, the computation is terminated. */
-
-	if (*info != 0) {
-	    goto L120;
-	}
-/* L20: */
-    }
-
-    if (*k == 1) {
-	goto L110;
-    }
-    if (*k == 2) {
-	i__1 = *k;
-	for (j = 1; j <= i__1; ++j) {
-	    w[1] = q[j * q_dim1 + 1];
-	    w[2] = q[j * q_dim1 + 2];
-	    ii = indx[1];
-	    q[j * q_dim1 + 1] = w[ii];
-	    ii = indx[2];
-	    q[j * q_dim1 + 2] = w[ii];
-/* L30: */
-	}
-	goto L110;
-    }
-
-/*     Compute updated W. */
-
-    dcopy_(k, &w[1], &c__1, &s[1], &c__1);
-
-/*     Initialize W(I) = Q(I,I) */
-
-    i__1 = *ldq + 1;
-    dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
-    i__1 = *k;
-    for (j = 1; j <= i__1; ++j) {
-	i__2 = j - 1;
-	for (i__ = 1; i__ <= i__2; ++i__) {
-	    w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
-/* L40: */
-	}
-	i__2 = *k;
-	for (i__ = j + 1; i__ <= i__2; ++i__) {
-	    w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
-/* L50: */
-	}
-/* L60: */
-    }
-    i__1 = *k;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	d__1 = sqrt(-w[i__]);
-	w[i__] = d_sign(&d__1, &s[i__]);
-/* L70: */
-    }
-
-/*     Compute eigenvectors of the modified rank-1 modification. */
-
-    i__1 = *k;
-    for (j = 1; j <= i__1; ++j) {
-	i__2 = *k;
-	for (i__ = 1; i__ <= i__2; ++i__) {
-	    s[i__] = w[i__] / q[i__ + j * q_dim1];
-/* L80: */
-	}
-	temp = dnrm2_(k, &s[1], &c__1);
-	i__2 = *k;
-	for (i__ = 1; i__ <= i__2; ++i__) {
-	    ii = indx[i__];
-	    q[i__ + j * q_dim1] = s[ii] / temp;
-/* L90: */
-	}
-/* L100: */
-    }
-
-/*     Compute the updated eigenvectors. */
-
-L110:
-
-    n2 = *n - *n1;
-    n12 = ctot[1] + ctot[2];
-    n23 = ctot[2] + ctot[3];
-
-    dlacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23);
-    iq2 = *n1 * n12 + 1;
-    if (n23 != 0) {
-	dgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
-		c_b23, &q[*n1 + 1 + q_dim1], ldq);
-    } else {
-	dlaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq);
-    }
-
-    dlacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12);
-    if (n12 != 0) {
-	dgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, 
-		 &q[q_offset], ldq);
-    } else {
-	dlaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq);
-    }
-
-
-L120:
-    return 0;
-
-/*     End of DLAED3 */
-
-} /* dlaed3_ */

3rdparty/lapack/dlaed4.c

@@ -1,954 +0,0 @@
-/* dlaed4.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlaed4_(integer *n, integer *i__, doublereal *d__, 
-	doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam, 
-	 integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    doublereal a, b, c__;
-    integer j;
-    doublereal w;
-    integer ii;
-    doublereal dw, zz[3];
-    integer ip1;
-    doublereal del, eta, phi, eps, tau, psi;
-    integer iim1, iip1;
-    doublereal dphi, dpsi;
-    integer iter;
-    doublereal temp, prew, temp1, dltlb, dltub, midpt;
-    integer niter;
-    logical swtch;
-    extern /* Subroutine */ int dlaed5_(integer *, doublereal *, doublereal *, 
-	     doublereal *, doublereal *, doublereal *), dlaed6_(integer *, 
-	    logical *, doublereal *, doublereal *, doublereal *, doublereal *, 
-	     doublereal *, integer *);
-    logical swtch3;
-    extern doublereal dlamch_(char *);
-    logical orgati;
-    doublereal erretm, rhoinv;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  This subroutine computes the I-th updated eigenvalue of a symmetric */
-/*  rank-one modification to a diagonal matrix whose elements are */
-/*  given in the array d, and that */
-
-/*             D(i) < D(j)  for  i < j */
-
-/*  and that RHO > 0.  This is arranged by the calling routine, and is */
-/*  no loss in generality.  The rank-one modified system is thus */
-
-/*             diag( D )  +  RHO *  Z * Z_transpose. */
-
-/*  where we assume the Euclidean norm of Z is 1. */
-
-/*  The method consists of approximating the rational functions in the */
-/*  secular equation by simpler interpolating rational functions. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N      (input) INTEGER */
-/*         The length of all arrays. */
-
-/*  I      (input) INTEGER */
-/*         The index of the eigenvalue to be computed.  1 <= I <= N. */
-
-/*  D      (input) DOUBLE PRECISION array, dimension (N) */
-/*         The original eigenvalues.  It is assumed that they are in */
-/*         order, D(I) < D(J)  for I < J. */
-
-/*  Z      (input) DOUBLE PRECISION array, dimension (N) */
-/*         The components of the updating vector. */
-
-/*  DELTA  (output) DOUBLE PRECISION array, dimension (N) */
-/*         If N .GT. 2, DELTA contains (D(j) - lambda_I) in its  j-th */
-/*         component.  If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5 */
-/*         for detail. The vector DELTA contains the information necessary */
-/*         to construct the eigenvectors by DLAED3 and DLAED9. */
-
-/*  RHO    (input) DOUBLE PRECISION */
-/*         The scalar in the symmetric updating formula. */
-
-/*  DLAM   (output) DOUBLE PRECISION */
-/*         The computed lambda_I, the I-th updated eigenvalue. */
-
-/*  INFO   (output) INTEGER */
-/*         = 0:  successful exit */
-/*         > 0:  if INFO = 1, the updating process failed. */
-
-/*  Internal Parameters */
-/*  =================== */
-
-/*  Logical variable ORGATI (origin-at-i?) is used for distinguishing */
-/*  whether D(i) or D(i+1) is treated as the origin. */
-
-/*            ORGATI = .true.    origin at i */
-/*            ORGATI = .false.   origin at i+1 */
-
-/*   Logical variable SWTCH3 (switch-for-3-poles?) is for noting */
-/*   if we are working with THREE poles! */
-
-/*   MAXIT is the maximum number of iterations allowed for each */
-/*   eigenvalue. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Ren-Cang Li, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Local Arrays .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Since this routine is called in an inner loop, we do no argument */
-/*     checking. */
-
-/*     Quick return for N=1 and 2. */
-
-    /* Parameter adjustments */
-    --delta;
-    --z__;
-    --d__;
-
-    /* Function Body */
-    *info = 0;
-    if (*n == 1) {
-
-/*         Presumably, I=1 upon entry */
-
-	*dlam = d__[1] + *rho * z__[1] * z__[1];
-	delta[1] = 1.;
-	return 0;
-    }
-    if (*n == 2) {
-	dlaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam);
-	return 0;
-    }
-
-/*     Compute machine epsilon */
-
-    eps = dlamch_("Epsilon");
-    rhoinv = 1. / *rho;
-
-/*     The case I = N */
-
-    if (*i__ == *n) {
-
-/*        Initialize some basic variables */
-
-	ii = *n - 1;
-	niter = 1;
-
-/*        Calculate initial guess */
-
-	midpt = *rho / 2.;
-
-/*        If ||Z||_2 is not one, then TEMP should be set to */
-/*        RHO * ||Z||_2^2 / TWO */
-
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    delta[j] = d__[j] - d__[*i__] - midpt;
-/* L10: */
-	}
-
-	psi = 0.;
-	i__1 = *n - 2;
-	for (j = 1; j <= i__1; ++j) {
-	    psi += z__[j] * z__[j] / delta[j];
-/* L20: */
-	}
-
-	c__ = rhoinv + psi;
-	w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[*
-		n];
-
-	if (w <= 0.) {
-	    temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho) 
-		    + z__[*n] * z__[*n] / *rho;
-	    if (c__ <= temp) {
-		tau = *rho;
-	    } else {
-		del = d__[*n] - d__[*n - 1];
-		a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]
-			;
-		b = z__[*n] * z__[*n] * del;
-		if (a < 0.) {
-		    tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a);
-		} else {
-		    tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.);
-		}
-	    }
-
-/*           It can be proved that */
-/*               D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO */
-
-	    dltlb = midpt;
-	    dltub = *rho;
-	} else {
-	    del = d__[*n] - d__[*n - 1];
-	    a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n];
-	    b = z__[*n] * z__[*n] * del;
-	    if (a < 0.) {
-		tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a);
-	    } else {
-		tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.);
-	    }
-
-/*           It can be proved that */
-/*               D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */
-
-	    dltlb = 0.;
-	    dltub = midpt;
-	}
-
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    delta[j] = d__[j] - d__[*i__] - tau;
-/* L30: */
-	}
-
-/*        Evaluate PSI and the derivative DPSI */
-
-	dpsi = 0.;
-	psi = 0.;
-	erretm = 0.;
-	i__1 = ii;
-	for (j = 1; j <= i__1; ++j) {
-	    temp = z__[j] / delta[j];
-	    psi += z__[j] * temp;
-	    dpsi += temp * temp;
-	    erretm += psi;
-/* L40: */
-	}
-	erretm = abs(erretm);
-
-/*        Evaluate PHI and the derivative DPHI */
-
-	temp = z__[*n] / delta[*n];
-	phi = z__[*n] * temp;
-	dphi = temp * temp;
-	erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi 
-		+ dphi);
-
-	w = rhoinv + phi + psi;
-
-/*        Test for convergence */
-
-	if (abs(w) <= eps * erretm) {
-	    *dlam = d__[*i__] + tau;
-	    goto L250;
-	}
-
-	if (w <= 0.) {
-	    dltlb = max(dltlb,tau);
-	} else {
-	    dltub = min(dltub,tau);
-	}
-
-/*        Calculate the new step */
-
-	++niter;
-	c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
-	a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * (
-		dpsi + dphi);
-	b = delta[*n - 1] * delta[*n] * w;
-	if (c__ < 0.) {
-	    c__ = abs(c__);
-	}
-	if (c__ == 0.) {
-/*          ETA = B/A */
-/*           ETA = RHO - TAU */
-	    eta = dltub - tau;
-	} else if (a >= 0.) {
-	    eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ 
-		    * 2.);
-	} else {
-	    eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))
-		    );
-	}
-
-/*        Note, eta should be positive if w is negative, and */
-/*        eta should be negative otherwise. However, */
-/*        if for some reason caused by roundoff, eta*w > 0, */
-/*        we simply use one Newton step instead. This way */
-/*        will guarantee eta*w < 0. */
-
-	if (w * eta > 0.) {
-	    eta = -w / (dpsi + dphi);
-	}
-	temp = tau + eta;
-	if (temp > dltub || temp < dltlb) {
-	    if (w < 0.) {
-		eta = (dltub - tau) / 2.;
-	    } else {
-		eta = (dltlb - tau) / 2.;
-	    }
-	}
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    delta[j] -= eta;
-/* L50: */
-	}
-
-	tau += eta;
-
-/*        Evaluate PSI and the derivative DPSI */
-
-	dpsi = 0.;
-	psi = 0.;
-	erretm = 0.;
-	i__1 = ii;
-	for (j = 1; j <= i__1; ++j) {
-	    temp = z__[j] / delta[j];
-	    psi += z__[j] * temp;
-	    dpsi += temp * temp;
-	    erretm += psi;
-/* L60: */
-	}
-	erretm = abs(erretm);
-
-/*        Evaluate PHI and the derivative DPHI */
-
-	temp = z__[*n] / delta[*n];
-	phi = z__[*n] * temp;
-	dphi = temp * temp;
-	erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi 
-		+ dphi);
-
-	w = rhoinv + phi + psi;
-
-/*        Main loop to update the values of the array   DELTA */
-
-	iter = niter + 1;
-
-	for (niter = iter; niter <= 30; ++niter) {
-
-/*           Test for convergence */
-
-	    if (abs(w) <= eps * erretm) {
-		*dlam = d__[*i__] + tau;
-		goto L250;
-	    }
-
-	    if (w <= 0.) {
-		dltlb = max(dltlb,tau);
-	    } else {
-		dltub = min(dltub,tau);
-	    }
-
-/*           Calculate the new step */
-
-	    c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
-	    a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * 
-		    (dpsi + dphi);
-	    b = delta[*n - 1] * delta[*n] * w;
-	    if (a >= 0.) {
-		eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
-			c__ * 2.);
-	    } else {
-		eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(
-			d__1))));
-	    }
-
-/*           Note, eta should be positive if w is negative, and */
-/*           eta should be negative otherwise. However, */
-/*           if for some reason caused by roundoff, eta*w > 0, */
-/*           we simply use one Newton step instead. This way */
-/*           will guarantee eta*w < 0. */
-
-	    if (w * eta > 0.) {
-		eta = -w / (dpsi + dphi);
-	    }
-	    temp = tau + eta;
-	    if (temp > dltub || temp < dltlb) {
-		if (w < 0.) {
-		    eta = (dltub - tau) / 2.;
-		} else {
-		    eta = (dltlb - tau) / 2.;
-		}
-	    }
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		delta[j] -= eta;
-/* L70: */
-	    }
-
-	    tau += eta;
-
-/*           Evaluate PSI and the derivative DPSI */
-
-	    dpsi = 0.;
-	    psi = 0.;
-	    erretm = 0.;
-	    i__1 = ii;
-	    for (j = 1; j <= i__1; ++j) {
-		temp = z__[j] / delta[j];
-		psi += z__[j] * temp;
-		dpsi += temp * temp;
-		erretm += psi;
-/* L80: */
-	    }
-	    erretm = abs(erretm);
-
-/*           Evaluate PHI and the derivative DPHI */
-
-	    temp = z__[*n] / delta[*n];
-	    phi = z__[*n] * temp;
-	    dphi = temp * temp;
-	    erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (
-		    dpsi + dphi);
-
-	    w = rhoinv + phi + psi;
-/* L90: */
-	}
-
-/*        Return with INFO = 1, NITER = MAXIT and not converged */
-
-	*info = 1;
-	*dlam = d__[*i__] + tau;
-	goto L250;
-
-/*        End for the case I = N */
-
-    } else {
-
-/*        The case for I < N */
-
-	niter = 1;
-	ip1 = *i__ + 1;
-
-/*        Calculate initial guess */
-
-	del = d__[ip1] - d__[*i__];
-	midpt = del / 2.;
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    delta[j] = d__[j] - d__[*i__] - midpt;
-/* L100: */
-	}
-
-	psi = 0.;
-	i__1 = *i__ - 1;
-	for (j = 1; j <= i__1; ++j) {
-	    psi += z__[j] * z__[j] / delta[j];
-/* L110: */
-	}
-
-	phi = 0.;
-	i__1 = *i__ + 2;
-	for (j = *n; j >= i__1; --j) {
-	    phi += z__[j] * z__[j] / delta[j];
-/* L120: */
-	}
-	c__ = rhoinv + psi + phi;
-	w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] / 
-		delta[ip1];
-
-	if (w > 0.) {
-
-/*           d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 */
-
-/*           We choose d(i) as origin. */
-
-	    orgati = TRUE_;
-	    a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1];
-	    b = z__[*i__] * z__[*i__] * del;
-	    if (a > 0.) {
-		tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(
-			d__1))));
-	    } else {
-		tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
-			c__ * 2.);
-	    }
-	    dltlb = 0.;
-	    dltub = midpt;
-	} else {
-
-/*           (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) */
-
-/*           We choose d(i+1) as origin. */
-
-	    orgati = FALSE_;
-	    a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1];
-	    b = z__[ip1] * z__[ip1] * del;
-	    if (a < 0.) {
-		tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs(
-			d__1))));
-	    } else {
-		tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / 
-			(c__ * 2.);
-	    }
-	    dltlb = -midpt;
-	    dltub = 0.;
-	}
-
-	if (orgati) {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		delta[j] = d__[j] - d__[*i__] - tau;
-/* L130: */
-	    }
-	} else {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		delta[j] = d__[j] - d__[ip1] - tau;
-/* L140: */
-	    }
-	}
-	if (orgati) {
-	    ii = *i__;
-	} else {
-	    ii = *i__ + 1;
-	}
-	iim1 = ii - 1;
-	iip1 = ii + 1;
-
-/*        Evaluate PSI and the derivative DPSI */
-
-	dpsi = 0.;
-	psi = 0.;
-	erretm = 0.;
-	i__1 = iim1;
-	for (j = 1; j <= i__1; ++j) {
-	    temp = z__[j] / delta[j];
-	    psi += z__[j] * temp;
-	    dpsi += temp * temp;
-	    erretm += psi;
-/* L150: */
-	}
-	erretm = abs(erretm);
-
-/*        Evaluate PHI and the derivative DPHI */
-
-	dphi = 0.;
-	phi = 0.;
-	i__1 = iip1;
-	for (j = *n; j >= i__1; --j) {
-	    temp = z__[j] / delta[j];
-	    phi += z__[j] * temp;
-	    dphi += temp * temp;
-	    erretm += phi;
-/* L160: */
-	}
-
-	w = rhoinv + phi + psi;
-
-/*        W is the value of the secular function with */
-/*        its ii-th element removed. */
-
-	swtch3 = FALSE_;
-	if (orgati) {
-	    if (w < 0.) {
-		swtch3 = TRUE_;
-	    }
-	} else {
-	    if (w > 0.) {
-		swtch3 = TRUE_;
-	    }
-	}
-	if (ii == 1 || ii == *n) {
-	    swtch3 = FALSE_;
-	}
-
-	temp = z__[ii] / delta[ii];
-	dw = dpsi + dphi + temp * temp;
-	temp = z__[ii] * temp;
-	w += temp;
-	erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + 
-		abs(tau) * dw;
-
-/*        Test for convergence */
-
-	if (abs(w) <= eps * erretm) {
-	    if (orgati) {
-		*dlam = d__[*i__] + tau;
-	    } else {
-		*dlam = d__[ip1] + tau;
-	    }
-	    goto L250;
-	}
-
-	if (w <= 0.) {
-	    dltlb = max(dltlb,tau);
-	} else {
-	    dltub = min(dltub,tau);
-	}
-
-/*        Calculate the new step */
-
-	++niter;
-	if (! swtch3) {
-	    if (orgati) {
-/* Computing 2nd power */
-		d__1 = z__[*i__] / delta[*i__];
-		c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 * 
-			d__1);
-	    } else {
-/* Computing 2nd power */
-		d__1 = z__[ip1] / delta[ip1];
-		c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 * 
-			d__1);
-	    }
-	    a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * 
-		    dw;
-	    b = delta[*i__] * delta[ip1] * w;
-	    if (c__ == 0.) {
-		if (a == 0.) {
-		    if (orgati) {
-			a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] * 
-				(dpsi + dphi);
-		    } else {
-			a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] * 
-				(dpsi + dphi);
-		    }
-		}
-		eta = b / a;
-	    } else if (a <= 0.) {
-		eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
-			c__ * 2.);
-	    } else {
-		eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(
-			d__1))));
-	    }
-	} else {
-
-/*           Interpolation using THREE most relevant poles */
-
-	    temp = rhoinv + psi + phi;
-	    if (orgati) {
-		temp1 = z__[iim1] / delta[iim1];
-		temp1 *= temp1;
-		c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[
-			iip1]) * temp1;
-		zz[0] = z__[iim1] * z__[iim1];
-		zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi);
-	    } else {
-		temp1 = z__[iip1] / delta[iip1];
-		temp1 *= temp1;
-		c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[
-			iim1]) * temp1;
-		zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1));
-		zz[2] = z__[iip1] * z__[iip1];
-	    }
-	    zz[1] = z__[ii] * z__[ii];
-	    dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info);
-	    if (*info != 0) {
-		goto L250;
-	    }
-	}
-
-/*        Note, eta should be positive if w is negative, and */
-/*        eta should be negative otherwise. However, */
-/*        if for some reason caused by roundoff, eta*w > 0, */
-/*        we simply use one Newton step instead. This way */
-/*        will guarantee eta*w < 0. */
-
-	if (w * eta >= 0.) {
-	    eta = -w / dw;
-	}
-	temp = tau + eta;
-	if (temp > dltub || temp < dltlb) {
-	    if (w < 0.) {
-		eta = (dltub - tau) / 2.;
-	    } else {
-		eta = (dltlb - tau) / 2.;
-	    }
-	}
-
-	prew = w;
-
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    delta[j] -= eta;
-/* L180: */
-	}
-
-/*        Evaluate PSI and the derivative DPSI */
-
-	dpsi = 0.;
-	psi = 0.;
-	erretm = 0.;
-	i__1 = iim1;
-	for (j = 1; j <= i__1; ++j) {
-	    temp = z__[j] / delta[j];
-	    psi += z__[j] * temp;
-	    dpsi += temp * temp;
-	    erretm += psi;
-/* L190: */
-	}
-	erretm = abs(erretm);
-
-/*        Evaluate PHI and the derivative DPHI */
-
-	dphi = 0.;
-	phi = 0.;
-	i__1 = iip1;
-	for (j = *n; j >= i__1; --j) {
-	    temp = z__[j] / delta[j];
-	    phi += z__[j] * temp;
-	    dphi += temp * temp;
-	    erretm += phi;
-/* L200: */
-	}
-
-	temp = z__[ii] / delta[ii];
-	dw = dpsi + dphi + temp * temp;
-	temp = z__[ii] * temp;
-	w = rhoinv + phi + psi + temp;
-	erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + (
-		d__1 = tau + eta, abs(d__1)) * dw;
-
-	swtch = FALSE_;
-	if (orgati) {
-	    if (-w > abs(prew) / 10.) {
-		swtch = TRUE_;
-	    }
-	} else {
-	    if (w > abs(prew) / 10.) {
-		swtch = TRUE_;
-	    }
-	}
-
-	tau += eta;
-
-/*        Main loop to update the values of the array   DELTA */
-
-	iter = niter + 1;
-
-	for (niter = iter; niter <= 30; ++niter) {
-
-/*           Test for convergence */
-
-	    if (abs(w) <= eps * erretm) {
-		if (orgati) {
-		    *dlam = d__[*i__] + tau;
-		} else {
-		    *dlam = d__[ip1] + tau;
-		}
-		goto L250;
-	    }
-
-	    if (w <= 0.) {
-		dltlb = max(dltlb,tau);
-	    } else {
-		dltub = min(dltub,tau);
-	    }
-
-/*           Calculate the new step */
-
-	    if (! swtch3) {
-		if (! swtch) {
-		    if (orgati) {
-/* Computing 2nd power */
-			d__1 = z__[*i__] / delta[*i__];
-			c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (
-				d__1 * d__1);
-		    } else {
-/* Computing 2nd power */
-			d__1 = z__[ip1] / delta[ip1];
-			c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * 
-				(d__1 * d__1);
-		    }
-		} else {
-		    temp = z__[ii] / delta[ii];
-		    if (orgati) {
-			dpsi += temp * temp;
-		    } else {
-			dphi += temp * temp;
-		    }
-		    c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi;
-		}
-		a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] 
-			* dw;
-		b = delta[*i__] * delta[ip1] * w;
-		if (c__ == 0.) {
-		    if (a == 0.) {
-			if (! swtch) {
-			    if (orgati) {
-				a = z__[*i__] * z__[*i__] + delta[ip1] * 
-					delta[ip1] * (dpsi + dphi);
-			    } else {
-				a = z__[ip1] * z__[ip1] + delta[*i__] * delta[
-					*i__] * (dpsi + dphi);
-			    }
-			} else {
-			    a = delta[*i__] * delta[*i__] * dpsi + delta[ip1] 
-				    * delta[ip1] * dphi;
-			}
-		    }
-		    eta = b / a;
-		} else if (a <= 0.) {
-		    eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))))
-			     / (c__ * 2.);
-		} else {
-		    eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, 
-			    abs(d__1))));
-		}
-	    } else {
-
-/*              Interpolation using THREE most relevant poles */
-
-		temp = rhoinv + psi + phi;
-		if (swtch) {
-		    c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi;
-		    zz[0] = delta[iim1] * delta[iim1] * dpsi;
-		    zz[2] = delta[iip1] * delta[iip1] * dphi;
-		} else {
-		    if (orgati) {
-			temp1 = z__[iim1] / delta[iim1];
-			temp1 *= temp1;
-			c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] 
-				- d__[iip1]) * temp1;
-			zz[0] = z__[iim1] * z__[iim1];
-			zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + 
-				dphi);
-		    } else {
-			temp1 = z__[iip1] / delta[iip1];
-			temp1 *= temp1;
-			c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] 
-				- d__[iim1]) * temp1;
-			zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - 
-				temp1));
-			zz[2] = z__[iip1] * z__[iip1];
-		    }
-		}
-		dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, 
-			info);
-		if (*info != 0) {
-		    goto L250;
-		}
-	    }
-
-/*           Note, eta should be positive if w is negative, and */
-/*           eta should be negative otherwise. However, */
-/*           if for some reason caused by roundoff, eta*w > 0, */
-/*           we simply use one Newton step instead. This way */
-/*           will guarantee eta*w < 0. */
-
-	    if (w * eta >= 0.) {
-		eta = -w / dw;
-	    }
-	    temp = tau + eta;
-	    if (temp > dltub || temp < dltlb) {
-		if (w < 0.) {
-		    eta = (dltub - tau) / 2.;
-		} else {
-		    eta = (dltlb - tau) / 2.;
-		}
-	    }
-
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		delta[j] -= eta;
-/* L210: */
-	    }
-
-	    tau += eta;
-	    prew = w;
-
-/*           Evaluate PSI and the derivative DPSI */
-
-	    dpsi = 0.;
-	    psi = 0.;
-	    erretm = 0.;
-	    i__1 = iim1;
-	    for (j = 1; j <= i__1; ++j) {
-		temp = z__[j] / delta[j];
-		psi += z__[j] * temp;
-		dpsi += temp * temp;
-		erretm += psi;
-/* L220: */
-	    }
-	    erretm = abs(erretm);
-
-/*           Evaluate PHI and the derivative DPHI */
-
-	    dphi = 0.;
-	    phi = 0.;
-	    i__1 = iip1;
-	    for (j = *n; j >= i__1; --j) {
-		temp = z__[j] / delta[j];
-		phi += z__[j] * temp;
-		dphi += temp * temp;
-		erretm += phi;
-/* L230: */
-	    }
-
-	    temp = z__[ii] / delta[ii];
-	    dw = dpsi + dphi + temp * temp;
-	    temp = z__[ii] * temp;
-	    w = rhoinv + phi + psi + temp;
-	    erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. 
-		    + abs(tau) * dw;
-	    if (w * prew > 0. && abs(w) > abs(prew) / 10.) {
-		swtch = ! swtch;
-	    }
-
-/* L240: */
-	}
-
-/*        Return with INFO = 1, NITER = MAXIT and not converged */
-
-	*info = 1;
-	if (orgati) {
-	    *dlam = d__[*i__] + tau;
-	} else {
-	    *dlam = d__[ip1] + tau;
-	}
-
-    }
-
-L250:
-
-    return 0;
-
-/*     End of DLAED4 */
-
-} /* dlaed4_ */

3rdparty/lapack/dlaed5.c

@@ -1,148 +0,0 @@
-/* dlaed5.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__, 
-	doublereal *delta, doublereal *rho, doublereal *dlam)
-{
-    /* System generated locals */
-    doublereal d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    doublereal b, c__, w, del, tau, temp;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  This subroutine computes the I-th eigenvalue of a symmetric rank-one */
-/*  modification of a 2-by-2 diagonal matrix */
-
-/*             diag( D )  +  RHO *  Z * transpose(Z) . */
-
-/*  The diagonal elements in the array D are assumed to satisfy */
-
-/*             D(i) < D(j)  for  i < j . */
-
-/*  We also assume RHO > 0 and that the Euclidean norm of the vector */
-/*  Z is one. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  I      (input) INTEGER */
-/*         The index of the eigenvalue to be computed.  I = 1 or I = 2. */
-
-/*  D      (input) DOUBLE PRECISION array, dimension (2) */
-/*         The original eigenvalues.  We assume D(1) < D(2). */
-
-/*  Z      (input) DOUBLE PRECISION array, dimension (2) */
-/*         The components of the updating vector. */
-
-/*  DELTA  (output) DOUBLE PRECISION array, dimension (2) */
-/*         The vector DELTA contains the information necessary */
-/*         to construct the eigenvectors. */
-
-/*  RHO    (input) DOUBLE PRECISION */
-/*         The scalar in the symmetric updating formula. */
-
-/*  DLAM   (output) DOUBLE PRECISION */
-/*         The computed lambda_I, the I-th updated eigenvalue. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Ren-Cang Li, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --delta;
-    --z__;
-    --d__;
-
-    /* Function Body */
-    del = d__[2] - d__[1];
-    if (*i__ == 1) {
-	w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.;
-	if (w > 0.) {
-	    b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
-	    c__ = *rho * z__[1] * z__[1] * del;
-
-/*           B > ZERO, always */
-
-	    tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1))));
-	    *dlam = d__[1] + tau;
-	    delta[1] = -z__[1] / tau;
-	    delta[2] = z__[2] / (del - tau);
-	} else {
-	    b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
-	    c__ = *rho * z__[2] * z__[2] * del;
-	    if (b > 0.) {
-		tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.));
-	    } else {
-		tau = (b - sqrt(b * b + c__ * 4.)) / 2.;
-	    }
-	    *dlam = d__[2] + tau;
-	    delta[1] = -z__[1] / (del + tau);
-	    delta[2] = -z__[2] / tau;
-	}
-	temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
-	delta[1] /= temp;
-	delta[2] /= temp;
-    } else {
-
-/*     Now I=2 */
-
-	b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
-	c__ = *rho * z__[2] * z__[2] * del;
-	if (b > 0.) {
-	    tau = (b + sqrt(b * b + c__ * 4.)) / 2.;
-	} else {
-	    tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.));
-	}
-	*dlam = d__[2] + tau;
-	delta[1] = -z__[1] / (del + tau);
-	delta[2] = -z__[2] / tau;
-	temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
-	delta[1] /= temp;
-	delta[2] /= temp;
-    }
-    return 0;
-
-/*     End OF DLAED5 */
-
-} /* dlaed5_ */

3rdparty/lapack/dlaed6.c

@@ -1,374 +0,0 @@
-/* dlaed6.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal *
-	rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal *
-	tau, integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1, d__2, d__3, d__4;
-
-    /* Builtin functions */
-    double sqrt(doublereal), log(doublereal), pow_di(doublereal *, integer *);
-
-    /* Local variables */
-    doublereal a, b, c__, f;
-    integer i__;
-    doublereal fc, df, ddf, lbd, eta, ubd, eps, base;
-    integer iter;
-    doublereal temp, temp1, temp2, temp3, temp4;
-    logical scale;
-    integer niter;
-    doublereal small1, small2, sminv1, sminv2;
-    extern doublereal dlamch_(char *);
-    doublereal dscale[3], sclfac, zscale[3], erretm, sclinv;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     February 2007 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAED6 computes the positive or negative root (closest to the origin) */
-/*  of */
-/*                   z(1)        z(2)        z(3) */
-/*  f(x) =   rho + --------- + ---------- + --------- */
-/*                  d(1)-x      d(2)-x      d(3)-x */
-
-/*  It is assumed that */
-
-/*        if ORGATI = .true. the root is between d(2) and d(3); */
-/*        otherwise it is between d(1) and d(2) */
-
-/*  This routine will be called by DLAED4 when necessary. In most cases, */
-/*  the root sought is the smallest in magnitude, though it might not be */
-/*  in some extremely rare situations. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  KNITER       (input) INTEGER */
-/*               Refer to DLAED4 for its significance. */
-
-/*  ORGATI       (input) LOGICAL */
-/*               If ORGATI is true, the needed root is between d(2) and */
-/*               d(3); otherwise it is between d(1) and d(2).  See */
-/*               DLAED4 for further details. */
-
-/*  RHO          (input) DOUBLE PRECISION */
-/*               Refer to the equation f(x) above. */
-
-/*  D            (input) DOUBLE PRECISION array, dimension (3) */
-/*               D satisfies d(1) < d(2) < d(3). */
-
-/*  Z            (input) DOUBLE PRECISION array, dimension (3) */
-/*               Each of the elements in z must be positive. */
-
-/*  FINIT        (input) DOUBLE PRECISION */
-/*               The value of f at 0. It is more accurate than the one */
-/*               evaluated inside this routine (if someone wants to do */
-/*               so). */
-
-/*  TAU          (output) DOUBLE PRECISION */
-/*               The root of the equation f(x). */
-
-/*  INFO         (output) INTEGER */
-/*               = 0: successful exit */
-/*               > 0: if INFO = 1, failure to converge */
-
-/*  Further Details */
-/*  =============== */
-
-/*  30/06/99: Based on contributions by */
-/*     Ren-Cang Li, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-
-/*  10/02/03: This version has a few statements commented out for thread */
-/*  safety (machine parameters are computed on each entry). SJH. */
-
-/*  05/10/06: Modified from a new version of Ren-Cang Li, use */
-/*     Gragg-Thornton-Warner cubic convergent scheme for better stability. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Local Arrays .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --z__;
-    --d__;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*orgati) {
-	lbd = d__[2];
-	ubd = d__[3];
-    } else {
-	lbd = d__[1];
-	ubd = d__[2];
-    }
-    if (*finit < 0.) {
-	lbd = 0.;
-    } else {
-	ubd = 0.;
-    }
-
-    niter = 1;
-    *tau = 0.;
-    if (*kniter == 2) {
-	if (*orgati) {
-	    temp = (d__[3] - d__[2]) / 2.;
-	    c__ = *rho + z__[1] / (d__[1] - d__[2] - temp);
-	    a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3];
-	    b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2];
-	} else {
-	    temp = (d__[1] - d__[2]) / 2.;
-	    c__ = *rho + z__[3] / (d__[3] - d__[2] - temp);
-	    a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2];
-	    b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1];
-	}
-/* Computing MAX */
-	d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__);
-	temp = max(d__1,d__2);
-	a /= temp;
-	b /= temp;
-	c__ /= temp;
-	if (c__ == 0.) {
-	    *tau = b / a;
-	} else if (a <= 0.) {
-	    *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
-		    c__ * 2.);
-	} else {
-	    *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))
-		    ));
-	}
-	if (*tau < lbd || *tau > ubd) {
-	    *tau = (lbd + ubd) / 2.;
-	}
-	if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) {
-	    *tau = 0.;
-	} else {
-	    temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau 
-		    * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / (
-		    d__[3] * (d__[3] - *tau));
-	    if (temp <= 0.) {
-		lbd = *tau;
-	    } else {
-		ubd = *tau;
-	    }
-	    if (abs(*finit) <= abs(temp)) {
-		*tau = 0.;
-	    }
-	}
-    }
-
-/*     get machine parameters for possible scaling to avoid overflow */
-
-/*     modified by Sven: parameters SMALL1, SMINV1, SMALL2, */
-/*     SMINV2, EPS are not SAVEd anymore between one call to the */
-/*     others but recomputed at each call */
-
-    eps = dlamch_("Epsilon");
-    base = dlamch_("Base");
-    i__1 = (integer) (log(dlamch_("SafMin")) / log(base) / 3.);
-    small1 = pow_di(&base, &i__1);
-    sminv1 = 1. / small1;
-    small2 = small1 * small1;
-    sminv2 = sminv1 * sminv1;
-
-/*     Determine if scaling of inputs necessary to avoid overflow */
-/*     when computing 1/TEMP**3 */
-
-    if (*orgati) {
-/* Computing MIN */
-	d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - *
-		tau, abs(d__2));
-	temp = min(d__3,d__4);
-    } else {
-/* Computing MIN */
-	d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - *
-		tau, abs(d__2));
-	temp = min(d__3,d__4);
-    }
-    scale = FALSE_;
-    if (temp <= small1) {
-	scale = TRUE_;
-	if (temp <= small2) {
-
-/*        Scale up by power of radix nearest 1/SAFMIN**(2/3) */
-
-	    sclfac = sminv2;
-	    sclinv = small2;
-	} else {
-
-/*        Scale up by power of radix nearest 1/SAFMIN**(1/3) */
-
-	    sclfac = sminv1;
-	    sclinv = small1;
-	}
-
-/*        Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */
-
-	for (i__ = 1; i__ <= 3; ++i__) {
-	    dscale[i__ - 1] = d__[i__] * sclfac;
-	    zscale[i__ - 1] = z__[i__] * sclfac;
-/* L10: */
-	}
-	*tau *= sclfac;
-	lbd *= sclfac;
-	ubd *= sclfac;
-    } else {
-
-/*        Copy D and Z to DSCALE and ZSCALE */
-
-	for (i__ = 1; i__ <= 3; ++i__) {
-	    dscale[i__ - 1] = d__[i__];
-	    zscale[i__ - 1] = z__[i__];
-/* L20: */
-	}
-    }
-
-    fc = 0.;
-    df = 0.;
-    ddf = 0.;
-    for (i__ = 1; i__ <= 3; ++i__) {
-	temp = 1. / (dscale[i__ - 1] - *tau);
-	temp1 = zscale[i__ - 1] * temp;
-	temp2 = temp1 * temp;
-	temp3 = temp2 * temp;
-	fc += temp1 / dscale[i__ - 1];
-	df += temp2;
-	ddf += temp3;
-/* L30: */
-    }
-    f = *finit + *tau * fc;
-
-    if (abs(f) <= 0.) {
-	goto L60;
-    }
-    if (f <= 0.) {
-	lbd = *tau;
-    } else {
-	ubd = *tau;
-    }
-
-/*        Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */
-/*                            scheme */
-
-/*     It is not hard to see that */
-
-/*           1) Iterations will go up monotonically */
-/*              if FINIT < 0; */
-
-/*           2) Iterations will go down monotonically */
-/*              if FINIT > 0. */
-
-    iter = niter + 1;
-
-    for (niter = iter; niter <= 40; ++niter) {
-
-	if (*orgati) {
-	    temp1 = dscale[1] - *tau;
-	    temp2 = dscale[2] - *tau;
-	} else {
-	    temp1 = dscale[0] - *tau;
-	    temp2 = dscale[1] - *tau;
-	}
-	a = (temp1 + temp2) * f - temp1 * temp2 * df;
-	b = temp1 * temp2 * f;
-	c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf;
-/* Computing MAX */
-	d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__);
-	temp = max(d__1,d__2);
-	a /= temp;
-	b /= temp;
-	c__ /= temp;
-	if (c__ == 0.) {
-	    eta = b / a;
-	} else if (a <= 0.) {
-	    eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ 
-		    * 2.);
-	} else {
-	    eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))
-		    );
-	}
-	if (f * eta >= 0.) {
-	    eta = -f / df;
-	}
-
-	*tau += eta;
-	if (*tau < lbd || *tau > ubd) {
-	    *tau = (lbd + ubd) / 2.;
-	}
-
-	fc = 0.;
-	erretm = 0.;
-	df = 0.;
-	ddf = 0.;
-	for (i__ = 1; i__ <= 3; ++i__) {
-	    temp = 1. / (dscale[i__ - 1] - *tau);
-	    temp1 = zscale[i__ - 1] * temp;
-	    temp2 = temp1 * temp;
-	    temp3 = temp2 * temp;
-	    temp4 = temp1 / dscale[i__ - 1];
-	    fc += temp4;
-	    erretm += abs(temp4);
-	    df += temp2;
-	    ddf += temp3;
-/* L40: */
-	}
-	f = *finit + *tau * fc;
-	erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df;
-	if (abs(f) <= eps * erretm) {
-	    goto L60;
-	}
-	if (f <= 0.) {
-	    lbd = *tau;
-	} else {
-	    ubd = *tau;
-	}
-/* L50: */
-    }
-    *info = 1;
-L60:
-
-/*     Undo scaling */
-
-    if (scale) {
-	*tau *= sclinv;
-    }
-    return 0;
-
-/*     End of DLAED6 */
-
-} /* dlaed6_ */

3rdparty/lapack/dlaed7.c

@@ -1,354 +0,0 @@
-/* dlaed7.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__2 = 2;
-static integer c__1 = 1;
-static doublereal c_b10 = 1.;
-static doublereal c_b11 = 0.;
-static integer c_n1 = -1;
-
-/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz, 
-	integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, 
-	doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer 
-	*cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer *
-	perm, integer *givptr, integer *givcol, doublereal *givnum, 
-	doublereal *work, integer *iwork, integer *info)
-{
-    /* System generated locals */
-    integer q_dim1, q_offset, i__1, i__2;
-
-    /* Builtin functions */
-    integer pow_ii(integer *, integer *);
-
-    /* Local variables */
-    integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr;
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *);
-    integer indxc, indxp;
-    extern /* Subroutine */ int dlaed8_(integer *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
-	     integer *, doublereal *, integer *, integer *, integer *, 
-	    doublereal *, integer *, integer *, integer *), dlaed9_(integer *, 
-	     integer *, integer *, integer *, doublereal *, doublereal *, 
-	    integer *, doublereal *, doublereal *, doublereal *, doublereal *, 
-	     integer *, integer *), dlaeda_(integer *, integer *, integer *, 
-	    integer *, integer *, integer *, integer *, integer *, doublereal 
-	    *, doublereal *, integer *, doublereal *, doublereal *, integer *)
-	    ;
-    integer idlmda;
-    extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, 
-	    integer *, integer *, integer *), xerbla_(char *, integer *);
-    integer coltyp;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAED7 computes the updated eigensystem of a diagonal */
-/*  matrix after modification by a rank-one symmetric matrix. This */
-/*  routine is used only for the eigenproblem which requires all */
-/*  eigenvalues and optionally eigenvectors of a dense symmetric matrix */
-/*  that has been reduced to tridiagonal form.  DLAED1 handles */
-/*  the case in which all eigenvalues and eigenvectors of a symmetric */
-/*  tridiagonal matrix are desired. */
-
-/*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
-
-/*     where Z = Q'u, u is a vector of length N with ones in the */
-/*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
-
-/*     The eigenvectors of the original matrix are stored in Q, and the */
-/*     eigenvalues are in D.  The algorithm consists of three stages: */
-
-/*        The first stage consists of deflating the size of the problem */
-/*        when there are multiple eigenvalues or if there is a zero in */
-/*        the Z vector.  For each such occurence the dimension of the */
-/*        secular equation problem is reduced by one.  This stage is */
-/*        performed by the routine DLAED8. */
-
-/*        The second stage consists of calculating the updated */
-/*        eigenvalues. This is done by finding the roots of the secular */
-/*        equation via the routine DLAED4 (as called by DLAED9). */
-/*        This routine also calculates the eigenvectors of the current */
-/*        problem. */
-
-/*        The final stage consists of computing the updated eigenvectors */
-/*        directly using the updated eigenvalues.  The eigenvectors for */
-/*        the current problem are multiplied with the eigenvectors from */
-/*        the overall problem. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  ICOMPQ  (input) INTEGER */
-/*          = 0:  Compute eigenvalues only. */
-/*          = 1:  Compute eigenvectors of original dense symmetric matrix */
-/*                also.  On entry, Q contains the orthogonal matrix used */
-/*                to reduce the original matrix to tridiagonal form. */
-
-/*  N      (input) INTEGER */
-/*         The dimension of the symmetric tridiagonal matrix.  N >= 0. */
-
-/*  QSIZ   (input) INTEGER */
-/*         The dimension of the orthogonal matrix used to reduce */
-/*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1. */
-
-/*  TLVLS  (input) INTEGER */
-/*         The total number of merging levels in the overall divide and */
-/*         conquer tree. */
-
-/*  CURLVL (input) INTEGER */
-/*         The current level in the overall merge routine, */
-/*         0 <= CURLVL <= TLVLS. */
-
-/*  CURPBM (input) INTEGER */
-/*         The current problem in the current level in the overall */
-/*         merge routine (counting from upper left to lower right). */
-
-/*  D      (input/output) DOUBLE PRECISION array, dimension (N) */
-/*         On entry, the eigenvalues of the rank-1-perturbed matrix. */
-/*         On exit, the eigenvalues of the repaired matrix. */
-
-/*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
-/*         On entry, the eigenvectors of the rank-1-perturbed matrix. */
-/*         On exit, the eigenvectors of the repaired tridiagonal matrix. */
-
-/*  LDQ    (input) INTEGER */
-/*         The leading dimension of the array Q.  LDQ >= max(1,N). */
-
-/*  INDXQ  (output) INTEGER array, dimension (N) */
-/*         The permutation which will reintegrate the subproblem just */
-/*         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) */
-/*         will be in ascending order. */
-
-/*  RHO    (input) DOUBLE PRECISION */
-/*         The subdiagonal element used to create the rank-1 */
-/*         modification. */
-
-/*  CUTPNT (input) INTEGER */
-/*         Contains the location of the last eigenvalue in the leading */
-/*         sub-matrix.  min(1,N) <= CUTPNT <= N. */
-
-/*  QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1) */
-/*         Stores eigenvectors of submatrices encountered during */
-/*         divide and conquer, packed together. QPTR points to */
-/*         beginning of the submatrices. */
-
-/*  QPTR   (input/output) INTEGER array, dimension (N+2) */
-/*         List of indices pointing to beginning of submatrices stored */
-/*         in QSTORE. The submatrices are numbered starting at the */
-/*         bottom left of the divide and conquer tree, from left to */
-/*         right and bottom to top. */
-
-/*  PRMPTR (input) INTEGER array, dimension (N lg N) */
-/*         Contains a list of pointers which indicate where in PERM a */
-/*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i) */
-/*         indicates the size of the permutation and also the size of */
-/*         the full, non-deflated problem. */
-
-/*  PERM   (input) INTEGER array, dimension (N lg N) */
-/*         Contains the permutations (from deflation and sorting) to be */
-/*         applied to each eigenblock. */
-
-/*  GIVPTR (input) INTEGER array, dimension (N lg N) */
-/*         Contains a list of pointers which indicate where in GIVCOL a */
-/*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i) */
-/*         indicates the number of Givens rotations. */
-
-/*  GIVCOL (input) INTEGER array, dimension (2, N lg N) */
-/*         Each pair of numbers indicates a pair of columns to take place */
-/*         in a Givens rotation. */
-
-/*  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */
-/*         Each number indicates the S value to be used in the */
-/*         corresponding Givens rotation. */
-
-/*  WORK   (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N) */
-
-/*  IWORK  (workspace) INTEGER array, dimension (4*N) */
-
-/*  INFO   (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-/*          > 0:  if INFO = 1, an eigenvalue did not converge */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Jeff Rutter, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    q_dim1 = *ldq;
-    q_offset = 1 + q_dim1;
-    q -= q_offset;
-    --indxq;
-    --qstore;
-    --qptr;
-    --prmptr;
-    --perm;
-    --givptr;
-    givcol -= 3;
-    givnum -= 3;
-    --work;
-    --iwork;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*icompq < 0 || *icompq > 1) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    } else if (*icompq == 1 && *qsiz < *n) {
-	*info = -4;
-    } else if (*ldq < max(1,*n)) {
-	*info = -9;
-    } else if (min(1,*n) > *cutpnt || *n < *cutpnt) {
-	*info = -12;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAED7", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0) {
-	return 0;
-    }
-
-/*     The following values are for bookkeeping purposes only.  They are */
-/*     integer pointers which indicate the portion of the workspace */
-/*     used by a particular array in DLAED8 and DLAED9. */
-
-    if (*icompq == 1) {
-	ldq2 = *qsiz;
-    } else {
-	ldq2 = *n;
-    }
-
-    iz = 1;
-    idlmda = iz + *n;
-    iw = idlmda + *n;
-    iq2 = iw + *n;
-    is = iq2 + *n * ldq2;
-
-    indx = 1;
-    indxc = indx + *n;
-    coltyp = indxc + *n;
-    indxp = coltyp + *n;
-
-/*     Form the z-vector which consists of the last row of Q_1 and the */
-/*     first row of Q_2. */
-
-    ptr = pow_ii(&c__2, tlvls) + 1;
-    i__1 = *curlvl - 1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	i__2 = *tlvls - i__;
-	ptr += pow_ii(&c__2, &i__2);
-/* L10: */
-    }
-    curr = ptr + *curpbm;
-    dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
-	    givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz 
-	    + *n], info);
-
-/*     When solving the final problem, we no longer need the stored data, */
-/*     so we will overwrite the data from this level onto the previously */
-/*     used storage space. */
-
-    if (*curlvl == *tlvls) {
-	qptr[curr] = 1;
-	prmptr[curr] = 1;
-	givptr[curr] = 1;
-    }
-
-/*     Sort and Deflate eigenvalues. */
-
-    dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, 
-	    cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], &
-	    perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1)
-	     + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[
-	    indx], info);
-    prmptr[curr + 1] = prmptr[curr] + *n;
-    givptr[curr + 1] += givptr[curr];
-
-/*     Solve Secular Equation. */
-
-    if (k != 0) {
-	dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], 
-		&work[iw], &qstore[qptr[curr]], &k, info);
-	if (*info != 0) {
-	    goto L30;
-	}
-	if (*icompq == 1) {
-	    dgemm_("N", "N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[
-		    qptr[curr]], &k, &c_b11, &q[q_offset], ldq);
-	}
-/* Computing 2nd power */
-	i__1 = k;
-	qptr[curr + 1] = qptr[curr] + i__1 * i__1;
-
-/*     Prepare the INDXQ sorting permutation. */
-
-	n1 = k;
-	n2 = *n - k;
-	dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
-    } else {
-	qptr[curr + 1] = qptr[curr];
-	i__1 = *n;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    indxq[i__] = i__;
-/* L20: */
-	}
-    }
-
-L30:
-    return 0;
-
-/*     End of DLAED7 */
-
-} /* dlaed7_ */

3rdparty/lapack/dlaed8.c

@@ -1,475 +0,0 @@
-/* dlaed8.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static doublereal c_b3 = -1.;
-static integer c__1 = 1;
-
-/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer 
-	*qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, 
-	doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda, 
-	 doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer 
-	*givptr, integer *givcol, doublereal *givnum, integer *indxp, integer 
-	*indx, integer *info)
-{
-    /* System generated locals */
-    integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    doublereal c__;
-    integer i__, j;
-    doublereal s, t;
-    integer k2, n1, n2, jp, n1p1;
-    doublereal eps, tau, tol;
-    integer jlam, imax, jmax;
-    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *), dscal_(
-	    integer *, doublereal *, doublereal *, integer *), dcopy_(integer 
-	    *, doublereal *, integer *, doublereal *, integer *);
-    extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
-    extern integer idamax_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, 
-	    integer *, integer *, integer *), dlacpy_(char *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAED8 merges the two sets of eigenvalues together into a single */
-/*  sorted set.  Then it tries to deflate the size of the problem. */
-/*  There are two ways in which deflation can occur:  when two or more */
-/*  eigenvalues are close together or if there is a tiny element in the */
-/*  Z vector.  For each such occurrence the order of the related secular */
-/*  equation problem is reduced by one. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  ICOMPQ  (input) INTEGER */
-/*          = 0:  Compute eigenvalues only. */
-/*          = 1:  Compute eigenvectors of original dense symmetric matrix */
-/*                also.  On entry, Q contains the orthogonal matrix used */
-/*                to reduce the original matrix to tridiagonal form. */
-
-/*  K      (output) INTEGER */
-/*         The number of non-deflated eigenvalues, and the order of the */
-/*         related secular equation. */
-
-/*  N      (input) INTEGER */
-/*         The dimension of the symmetric tridiagonal matrix.  N >= 0. */
-
-/*  QSIZ   (input) INTEGER */
-/*         The dimension of the orthogonal matrix used to reduce */
-/*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1. */
-
-/*  D      (input/output) DOUBLE PRECISION array, dimension (N) */
-/*         On entry, the eigenvalues of the two submatrices to be */
-/*         combined.  On exit, the trailing (N-K) updated eigenvalues */
-/*         (those which were deflated) sorted into increasing order. */
-
-/*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
-/*         If ICOMPQ = 0, Q is not referenced.  Otherwise, */
-/*         on entry, Q contains the eigenvectors of the partially solved */
-/*         system which has been previously updated in matrix */
-/*         multiplies with other partially solved eigensystems. */
-/*         On exit, Q contains the trailing (N-K) updated eigenvectors */
-/*         (those which were deflated) in its last N-K columns. */
-
-/*  LDQ    (input) INTEGER */
-/*         The leading dimension of the array Q.  LDQ >= max(1,N). */
-
-/*  INDXQ  (input) INTEGER array, dimension (N) */
-/*         The permutation which separately sorts the two sub-problems */
-/*         in D into ascending order.  Note that elements in the second */
-/*         half of this permutation must first have CUTPNT added to */
-/*         their values in order to be accurate. */
-
-/*  RHO    (input/output) DOUBLE PRECISION */
-/*         On entry, the off-diagonal element associated with the rank-1 */
-/*         cut which originally split the two submatrices which are now */
-/*         being recombined. */
-/*         On exit, RHO has been modified to the value required by */
-/*         DLAED3. */
-
-/*  CUTPNT (input) INTEGER */
-/*         The location of the last eigenvalue in the leading */
-/*         sub-matrix.  min(1,N) <= CUTPNT <= N. */
-
-/*  Z      (input) DOUBLE PRECISION array, dimension (N) */
-/*         On entry, Z contains the updating vector (the last row of */
-/*         the first sub-eigenvector matrix and the first row of the */
-/*         second sub-eigenvector matrix). */
-/*         On exit, the contents of Z are destroyed by the updating */
-/*         process. */
-
-/*  DLAMDA (output) DOUBLE PRECISION array, dimension (N) */
-/*         A copy of the first K eigenvalues which will be used by */
-/*         DLAED3 to form the secular equation. */
-
-/*  Q2     (output) DOUBLE PRECISION array, dimension (LDQ2,N) */
-/*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise, */
-/*         a copy of the first K eigenvectors which will be used by */
-/*         DLAED7 in a matrix multiply (DGEMM) to update the new */
-/*         eigenvectors. */
-
-/*  LDQ2   (input) INTEGER */
-/*         The leading dimension of the array Q2.  LDQ2 >= max(1,N). */
-
-/*  W      (output) DOUBLE PRECISION array, dimension (N) */
-/*         The first k values of the final deflation-altered z-vector and */
-/*         will be passed to DLAED3. */
-
-/*  PERM   (output) INTEGER array, dimension (N) */
-/*         The permutations (from deflation and sorting) to be applied */
-/*         to each eigenblock. */
-
-/*  GIVPTR (output) INTEGER */
-/*         The number of Givens rotations which took place in this */
-/*         subproblem. */
-
-/*  GIVCOL (output) INTEGER array, dimension (2, N) */
-/*         Each pair of numbers indicates a pair of columns to take place */
-/*         in a Givens rotation. */
-
-/*  GIVNUM (output) DOUBLE PRECISION array, dimension (2, N) */
-/*         Each number indicates the S value to be used in the */
-/*         corresponding Givens rotation. */
-
-/*  INDXP  (workspace) INTEGER array, dimension (N) */
-/*         The permutation used to place deflated values of D at the end */
-/*         of the array.  INDXP(1:K) points to the nondeflated D-values */
-/*         and INDXP(K+1:N) points to the deflated eigenvalues. */
-
-/*  INDX   (workspace) INTEGER array, dimension (N) */
-/*         The permutation used to sort the contents of D into ascending */
-/*         order. */
-
-/*  INFO   (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Jeff Rutter, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    q_dim1 = *ldq;
-    q_offset = 1 + q_dim1;
-    q -= q_offset;
-    --indxq;
-    --z__;
-    --dlamda;
-    q2_dim1 = *ldq2;
-    q2_offset = 1 + q2_dim1;
-    q2 -= q2_offset;
-    --w;
-    --perm;
-    givcol -= 3;
-    givnum -= 3;
-    --indxp;
-    --indx;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*icompq < 0 || *icompq > 1) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -3;
-    } else if (*icompq == 1 && *qsiz < *n) {
-	*info = -4;
-    } else if (*ldq < max(1,*n)) {
-	*info = -7;
-    } else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
-	*info = -10;
-    } else if (*ldq2 < max(1,*n)) {
-	*info = -14;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAED8", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0) {
-	return 0;
-    }
-
-    n1 = *cutpnt;
-    n2 = *n - n1;
-    n1p1 = n1 + 1;
-
-    if (*rho < 0.) {
-	dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
-    }
-
-/*     Normalize z so that norm(z) = 1 */
-
-    t = 1. / sqrt(2.);
-    i__1 = *n;
-    for (j = 1; j <= i__1; ++j) {
-	indx[j] = j;
-/* L10: */
-    }
-    dscal_(n, &t, &z__[1], &c__1);
-    *rho = (d__1 = *rho * 2., abs(d__1));
-
-/*     Sort the eigenvalues into increasing order */
-
-    i__1 = *n;
-    for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
-	indxq[i__] += *cutpnt;
-/* L20: */
-    }
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dlamda[i__] = d__[indxq[i__]];
-	w[i__] = z__[indxq[i__]];
-/* L30: */
-    }
-    i__ = 1;
-    j = *cutpnt + 1;
-    dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	d__[i__] = dlamda[indx[i__]];
-	z__[i__] = w[indx[i__]];
-/* L40: */
-    }
-
-/*     Calculate the allowable deflation tolerence */
-
-    imax = idamax_(n, &z__[1], &c__1);
-    jmax = idamax_(n, &d__[1], &c__1);
-    eps = dlamch_("Epsilon");
-    tol = eps * 8. * (d__1 = d__[jmax], abs(d__1));
-
-/*     If the rank-1 modifier is small enough, no more needs to be done */
-/*     except to reorganize Q so that its columns correspond with the */
-/*     elements in D. */
-
-    if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
-	*k = 0;
-	if (*icompq == 0) {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		perm[j] = indxq[indx[j]];
-/* L50: */
-	    }
-	} else {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		perm[j] = indxq[indx[j]];
-		dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 
-			+ 1], &c__1);
-/* L60: */
-	    }
-	    dlacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq);
-	}
-	return 0;
-    }
-
-/*     If there are multiple eigenvalues then the problem deflates.  Here */
-/*     the number of equal eigenvalues are found.  As each equal */
-/*     eigenvalue is found, an elementary reflector is computed to rotate */
-/*     the corresponding eigensubspace so that the corresponding */
-/*     components of Z are zero in this new basis. */
-
-    *k = 0;
-    *givptr = 0;
-    k2 = *n + 1;
-    i__1 = *n;
-    for (j = 1; j <= i__1; ++j) {
-	if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
-
-/*           Deflate due to small z component. */
-
-	    --k2;
-	    indxp[k2] = j;
-	    if (j == *n) {
-		goto L110;
-	    }
-	} else {
-	    jlam = j;
-	    goto L80;
-	}
-/* L70: */
-    }
-L80:
-    ++j;
-    if (j > *n) {
-	goto L100;
-    }
-    if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
-
-/*        Deflate due to small z component. */
-
-	--k2;
-	indxp[k2] = j;
-    } else {
-
-/*        Check if eigenvalues are close enough to allow deflation. */
-
-	s = z__[jlam];
-	c__ = z__[j];
-
-/*        Find sqrt(a**2+b**2) without overflow or */
-/*        destructive underflow. */
-
-	tau = dlapy2_(&c__, &s);
-	t = d__[j] - d__[jlam];
-	c__ /= tau;
-	s = -s / tau;
-	if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
-
-/*           Deflation is possible. */
-
-	    z__[j] = tau;
-	    z__[jlam] = 0.;
-
-/*           Record the appropriate Givens rotation */
-
-	    ++(*givptr);
-	    givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
-	    givcol[(*givptr << 1) + 2] = indxq[indx[j]];
-	    givnum[(*givptr << 1) + 1] = c__;
-	    givnum[(*givptr << 1) + 2] = s;
-	    if (*icompq == 1) {
-		drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[
-			indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
-	    }
-	    t = d__[jlam] * c__ * c__ + d__[j] * s * s;
-	    d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
-	    d__[jlam] = t;
-	    --k2;
-	    i__ = 1;
-L90:
-	    if (k2 + i__ <= *n) {
-		if (d__[jlam] < d__[indxp[k2 + i__]]) {
-		    indxp[k2 + i__ - 1] = indxp[k2 + i__];
-		    indxp[k2 + i__] = jlam;
-		    ++i__;
-		    goto L90;
-		} else {
-		    indxp[k2 + i__ - 1] = jlam;
-		}
-	    } else {
-		indxp[k2 + i__ - 1] = jlam;
-	    }
-	    jlam = j;
-	} else {
-	    ++(*k);
-	    w[*k] = z__[jlam];
-	    dlamda[*k] = d__[jlam];
-	    indxp[*k] = jlam;
-	    jlam = j;
-	}
-    }
-    goto L80;
-L100:
-
-/*     Record the last eigenvalue. */
-
-    ++(*k);
-    w[*k] = z__[jlam];
-    dlamda[*k] = d__[jlam];
-    indxp[*k] = jlam;
-
-L110:
-
-/*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
-/*     and Q2 respectively.  The eigenvalues/vectors which were not */
-/*     deflated go into the first K slots of DLAMDA and Q2 respectively, */
-/*     while those which were deflated go into the last N - K slots. */
-
-    if (*icompq == 0) {
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    jp = indxp[j];
-	    dlamda[j] = d__[jp];
-	    perm[j] = indxq[indx[jp]];
-/* L120: */
-	}
-    } else {
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    jp = indxp[j];
-	    dlamda[j] = d__[jp];
-	    perm[j] = indxq[indx[jp]];
-	    dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
-, &c__1);
-/* L130: */
-	}
-    }
-
-/*     The deflated eigenvalues and their corresponding vectors go back */
-/*     into the last N - K slots of D and Q respectively. */
-
-    if (*k < *n) {
-	if (*icompq == 0) {
-	    i__1 = *n - *k;
-	    dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
-	} else {
-	    i__1 = *n - *k;
-	    dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
-	    i__1 = *n - *k;
-	    dlacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*
-		    k + 1) * q_dim1 + 1], ldq);
-	}
-    }
-
-    return 0;
-
-/*     End of DLAED8 */
-
-} /* dlaed8_ */

3rdparty/lapack/dlaed9.c

@@ -1,274 +0,0 @@
-/* dlaed9.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-
-/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop, 
-	integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal *
-	rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds, 
-	integer *info)
-{
-    /* System generated locals */
-    integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal), d_sign(doublereal *, doublereal *);
-
-    /* Local variables */
-    integer i__, j;
-    doublereal temp;
-    extern doublereal dnrm2_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *), dlaed4_(integer *, integer *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, 
-	    doublereal *, integer *);
-    extern doublereal dlamc3_(doublereal *, doublereal *);
-    extern /* Subroutine */ int xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAED9 finds the roots of the secular equation, as defined by the */
-/*  values in D, Z, and RHO, between KSTART and KSTOP.  It makes the */
-/*  appropriate calls to DLAED4 and then stores the new matrix of */
-/*  eigenvectors for use in calculating the next level of Z vectors. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  K       (input) INTEGER */
-/*          The number of terms in the rational function to be solved by */
-/*          DLAED4.  K >= 0. */
-
-/*  KSTART  (input) INTEGER */
-/*  KSTOP   (input) INTEGER */
-/*          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP */
-/*          are to be computed.  1 <= KSTART <= KSTOP <= K. */
-
-/*  N       (input) INTEGER */
-/*          The number of rows and columns in the Q matrix. */
-/*          N >= K (delation may result in N > K). */
-
-/*  D       (output) DOUBLE PRECISION array, dimension (N) */
-/*          D(I) contains the updated eigenvalues */
-/*          for KSTART <= I <= KSTOP. */
-
-/*  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ,N) */
-
-/*  LDQ     (input) INTEGER */
-/*          The leading dimension of the array Q.  LDQ >= max( 1, N ). */
-
-/*  RHO     (input) DOUBLE PRECISION */
-/*          The value of the parameter in the rank one update equation. */
-/*          RHO >= 0 required. */
-
-/*  DLAMDA  (input) DOUBLE PRECISION array, dimension (K) */
-/*          The first K elements of this array contain the old roots */
-/*          of the deflated updating problem.  These are the poles */
-/*          of the secular equation. */
-
-/*  W       (input) DOUBLE PRECISION array, dimension (K) */
-/*          The first K elements of this array contain the components */
-/*          of the deflation-adjusted updating vector. */
-
-/*  S       (output) DOUBLE PRECISION array, dimension (LDS, K) */
-/*          Will contain the eigenvectors of the repaired matrix which */
-/*          will be stored for subsequent Z vector calculation and */
-/*          multiplied by the previously accumulated eigenvectors */
-/*          to update the system. */
-
-/*  LDS     (input) INTEGER */
-/*          The leading dimension of S.  LDS >= max( 1, K ). */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-/*          > 0:  if INFO = 1, an eigenvalue did not converge */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Jeff Rutter, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    q_dim1 = *ldq;
-    q_offset = 1 + q_dim1;
-    q -= q_offset;
-    --dlamda;
-    --w;
-    s_dim1 = *lds;
-    s_offset = 1 + s_dim1;
-    s -= s_offset;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*k < 0) {
-	*info = -1;
-    } else if (*kstart < 1 || *kstart > max(1,*k)) {
-	*info = -2;
-    } else if (max(1,*kstop) < *kstart || *kstop > max(1,*k)) {
-	*info = -3;
-    } else if (*n < *k) {
-	*info = -4;
-    } else if (*ldq < max(1,*k)) {
-	*info = -7;
-    } else if (*lds < max(1,*k)) {
-	*info = -12;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAED9", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*k == 0) {
-	return 0;
-    }
-
-/*     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
-/*     be computed with high relative accuracy (barring over/underflow). */
-/*     This is a problem on machines without a guard digit in */
-/*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
-/*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
-/*     which on any of these machines zeros out the bottommost */
-/*     bit of DLAMDA(I) if it is 1; this makes the subsequent */
-/*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
-/*     occurs. On binary machines with a guard digit (almost all */
-/*     machines) it does not change DLAMDA(I) at all. On hexadecimal */
-/*     and decimal machines with a guard digit, it slightly */
-/*     changes the bottommost bits of DLAMDA(I). It does not account */
-/*     for hexadecimal or decimal machines without guard digits */
-/*     (we know of none). We use a subroutine call to compute */
-/*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
-/*     this code. */
-
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
-/* L10: */
-    }
-
-    i__1 = *kstop;
-    for (j = *kstart; j <= i__1; ++j) {
-	dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], 
-		info);
-
-/*        If the zero finder fails, the computation is terminated. */
-
-	if (*info != 0) {
-	    goto L120;
-	}
-/* L20: */
-    }
-
-    if (*k == 1 || *k == 2) {
-	i__1 = *k;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    i__2 = *k;
-	    for (j = 1; j <= i__2; ++j) {
-		s[j + i__ * s_dim1] = q[j + i__ * q_dim1];
-/* L30: */
-	    }
-/* L40: */
-	}
-	goto L120;
-    }
-
-/*     Compute updated W. */
-
-    dcopy_(k, &w[1], &c__1, &s[s_offset], &c__1);
-
-/*     Initialize W(I) = Q(I,I) */
-
-    i__1 = *ldq + 1;
-    dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
-    i__1 = *k;
-    for (j = 1; j <= i__1; ++j) {
-	i__2 = j - 1;
-	for (i__ = 1; i__ <= i__2; ++i__) {
-	    w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
-/* L50: */
-	}
-	i__2 = *k;
-	for (i__ = j + 1; i__ <= i__2; ++i__) {
-	    w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
-/* L60: */
-	}
-/* L70: */
-    }
-    i__1 = *k;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	d__1 = sqrt(-w[i__]);
-	w[i__] = d_sign(&d__1, &s[i__ + s_dim1]);
-/* L80: */
-    }
-
-/*     Compute eigenvectors of the modified rank-1 modification. */
-
-    i__1 = *k;
-    for (j = 1; j <= i__1; ++j) {
-	i__2 = *k;
-	for (i__ = 1; i__ <= i__2; ++i__) {
-	    q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1];
-/* L90: */
-	}
-	temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1);
-	i__2 = *k;
-	for (i__ = 1; i__ <= i__2; ++i__) {
-	    s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp;
-/* L100: */
-	}
-/* L110: */
-    }
-
-L120:
-    return 0;
-
-/*     End of DLAED9 */
-
-} /* dlaed9_ */

3rdparty/lapack/dlaeda.c

@@ -1,287 +0,0 @@
-/* dlaeda.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__2 = 2;
-static integer c__1 = 1;
-static doublereal c_b24 = 1.;
-static doublereal c_b26 = 0.;
-
-/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl, 
-	integer *curpbm, integer *prmptr, integer *perm, integer *givptr, 
-	integer *givcol, doublereal *givnum, doublereal *q, integer *qptr, 
-	doublereal *z__, doublereal *ztemp, integer *info)
-{
-    /* System generated locals */
-    integer i__1, i__2, i__3;
-
-    /* Builtin functions */
-    integer pow_ii(integer *, integer *);
-    double sqrt(doublereal);
-
-    /* Local variables */
-    integer i__, k, mid, ptr;
-    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *);
-    integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1;
-    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
-	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
-	    doublereal *, doublereal *, integer *), dcopy_(integer *, 
-	    doublereal *, integer *, doublereal *, integer *), xerbla_(char *, 
-	     integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAEDA computes the Z vector corresponding to the merge step in the */
-/*  CURLVLth step of the merge process with TLVLS steps for the CURPBMth */
-/*  problem. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N      (input) INTEGER */
-/*         The dimension of the symmetric tridiagonal matrix.  N >= 0. */
-
-/*  TLVLS  (input) INTEGER */
-/*         The total number of merging levels in the overall divide and */
-/*         conquer tree. */
-
-/*  CURLVL (input) INTEGER */
-/*         The current level in the overall merge routine, */
-/*         0 <= curlvl <= tlvls. */
-
-/*  CURPBM (input) INTEGER */
-/*         The current problem in the current level in the overall */
-/*         merge routine (counting from upper left to lower right). */
-
-/*  PRMPTR (input) INTEGER array, dimension (N lg N) */
-/*         Contains a list of pointers which indicate where in PERM a */
-/*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i) */
-/*         indicates the size of the permutation and incidentally the */
-/*         size of the full, non-deflated problem. */
-
-/*  PERM   (input) INTEGER array, dimension (N lg N) */
-/*         Contains the permutations (from deflation and sorting) to be */
-/*         applied to each eigenblock. */
-
-/*  GIVPTR (input) INTEGER array, dimension (N lg N) */
-/*         Contains a list of pointers which indicate where in GIVCOL a */
-/*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i) */
-/*         indicates the number of Givens rotations. */
-
-/*  GIVCOL (input) INTEGER array, dimension (2, N lg N) */
-/*         Each pair of numbers indicates a pair of columns to take place */
-/*         in a Givens rotation. */
-
-/*  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */
-/*         Each number indicates the S value to be used in the */
-/*         corresponding Givens rotation. */
-
-/*  Q      (input) DOUBLE PRECISION array, dimension (N**2) */
-/*         Contains the square eigenblocks from previous levels, the */
-/*         starting positions for blocks are given by QPTR. */
-
-/*  QPTR   (input) INTEGER array, dimension (N+2) */
-/*         Contains a list of pointers which indicate where in Q an */
-/*         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates */
-/*         the size of the block. */
-
-/*  Z      (output) DOUBLE PRECISION array, dimension (N) */
-/*         On output this vector contains the updating vector (the last */
-/*         row of the first sub-eigenvector matrix and the first row of */
-/*         the second sub-eigenvector matrix). */
-
-/*  ZTEMP  (workspace) DOUBLE PRECISION array, dimension (N) */
-
-/*  INFO   (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Jeff Rutter, Computer Science Division, University of California */
-/*     at Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --ztemp;
-    --z__;
-    --qptr;
-    --q;
-    givnum -= 3;
-    givcol -= 3;
-    --givptr;
-    --perm;
-    --prmptr;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*n < 0) {
-	*info = -1;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAEDA", &i__1);
-	return 0;
-    }
-
-/*     Quick return if possible */
-
-    if (*n == 0) {
-	return 0;
-    }
-
-/*     Determine location of first number in second half. */
-
-    mid = *n / 2 + 1;
-
-/*     Gather last/first rows of appropriate eigenblocks into center of Z */
-
-    ptr = 1;
-
-/*     Determine location of lowest level subproblem in the full storage */
-/*     scheme */
-
-    i__1 = *curlvl - 1;
-    curr = ptr + *curpbm * pow_ii(&c__2, curlvl) + pow_ii(&c__2, &i__1) - 1;
-
-/*     Determine size of these matrices.  We add HALF to the value of */
-/*     the SQRT in case the machine underestimates one of these square */
-/*     roots. */
-
-    bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + .5);
-    bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])) + 
-	    .5);
-    i__1 = mid - bsiz1 - 1;
-    for (k = 1; k <= i__1; ++k) {
-	z__[k] = 0.;
-/* L10: */
-    }
-    dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], &
-	    c__1);
-    dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1);
-    i__1 = *n;
-    for (k = mid + bsiz2; k <= i__1; ++k) {
-	z__[k] = 0.;
-/* L20: */
-    }
-
-/*     Loop thru remaining levels 1 -> CURLVL applying the Givens */
-/*     rotations and permutation and then multiplying the center matrices */
-/*     against the current Z. */
-
-    ptr = pow_ii(&c__2, tlvls) + 1;
-    i__1 = *curlvl - 1;
-    for (k = 1; k <= i__1; ++k) {
-	i__2 = *curlvl - k;
-	i__3 = *curlvl - k - 1;
-	curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) - 
-		1;
-	psiz1 = prmptr[curr + 1] - prmptr[curr];
-	psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
-	zptr1 = mid - psiz1;
-
-/*       Apply Givens at CURR and CURR+1 */
-
-	i__2 = givptr[curr + 1] - 1;
-	for (i__ = givptr[curr]; i__ <= i__2; ++i__) {
-	    drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, &
-		    z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[(
-		    i__ << 1) + 1], &givnum[(i__ << 1) + 2]);
-/* L30: */
-	}
-	i__2 = givptr[curr + 2] - 1;
-	for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) {
-	    drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[
-		    mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << 
-		    1) + 1], &givnum[(i__ << 1) + 2]);
-/* L40: */
-	}
-	psiz1 = prmptr[curr + 1] - prmptr[curr];
-	psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
-	i__2 = psiz1 - 1;
-	for (i__ = 0; i__ <= i__2; ++i__) {
-	    ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1];
-/* L50: */
-	}
-	i__2 = psiz2 - 1;
-	for (i__ = 0; i__ <= i__2; ++i__) {
-	    ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - 
-		    1];
-/* L60: */
-	}
-
-/*        Multiply Blocks at CURR and CURR+1 */
-
-/*        Determine size of these matrices.  We add HALF to the value of */
-/*        the SQRT in case the machine underestimates one of these */
-/*        square roots. */
-
-	bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + 
-		.5);
-	bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])
-		) + .5);
-	if (bsiz1 > 0) {
-	    dgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, &
-		    ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1);
-	}
-	i__2 = psiz1 - bsiz1;
-	dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1);
-	if (bsiz2 > 0) {
-	    dgemv_("T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, &
-		    ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1);
-	}
-	i__2 = psiz2 - bsiz2;
-	dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], &
-		c__1);
-
-	i__2 = *tlvls - k;
-	ptr += pow_ii(&c__2, &i__2);
-/* L70: */
-    }
-
-    return 0;
-
-/*     End of DLAEDA */
-
-} /* dlaeda_ */

3rdparty/lapack/dlaev2.c

@@ -1,188 +0,0 @@
-/* dlaev2.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__, 
-	doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1)
-{
-    /* System generated locals */
-    doublereal d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    doublereal ab, df, cs, ct, tb, sm, tn, rt, adf, acs;
-    integer sgn1, sgn2;
-    doublereal acmn, acmx;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */
-/*     [  A   B  ] */
-/*     [  B   C  ]. */
-/*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */
-/*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */
-/*  eigenvector for RT1, giving the decomposition */
-
-/*     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ] */
-/*     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ]. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  A       (input) DOUBLE PRECISION */
-/*          The (1,1) element of the 2-by-2 matrix. */
-
-/*  B       (input) DOUBLE PRECISION */
-/*          The (1,2) element and the conjugate of the (2,1) element of */
-/*          the 2-by-2 matrix. */
-
-/*  C       (input) DOUBLE PRECISION */
-/*          The (2,2) element of the 2-by-2 matrix. */
-
-/*  RT1     (output) DOUBLE PRECISION */
-/*          The eigenvalue of larger absolute value. */
-
-/*  RT2     (output) DOUBLE PRECISION */
-/*          The eigenvalue of smaller absolute value. */
-
-/*  CS1     (output) DOUBLE PRECISION */
-/*  SN1     (output) DOUBLE PRECISION */
-/*          The vector (CS1, SN1) is a unit right eigenvector for RT1. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  RT1 is accurate to a few ulps barring over/underflow. */
-
-/*  RT2 may be inaccurate if there is massive cancellation in the */
-/*  determinant A*C-B*B; higher precision or correctly rounded or */
-/*  correctly truncated arithmetic would be needed to compute RT2 */
-/*  accurately in all cases. */
-
-/*  CS1 and SN1 are accurate to a few ulps barring over/underflow. */
-
-/*  Overflow is possible only if RT1 is within a factor of 5 of overflow. */
-/*  Underflow is harmless if the input data is 0 or exceeds */
-/*     underflow_threshold / macheps. */
-
-/* ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Compute the eigenvalues */
-
-    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) {
-/* Computing 2nd power */
-	d__1 = ab / adf;
-	rt = adf * sqrt(d__1 * d__1 + 1.);
-    } else if (adf < ab) {
-/* Computing 2nd power */
-	d__1 = adf / ab;
-	rt = ab * sqrt(d__1 * d__1 + 1.);
-    } else {
-
-/*        Includes case AB=ADF=0 */
-
-	rt = ab * sqrt(2.);
-    }
-    if (sm < 0.) {
-	*rt1 = (sm - rt) * .5;
-	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 > 0.) {
-	*rt1 = (sm + rt) * .5;
-	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 = rt * .5;
-	*rt2 = rt * -.5;
-	sgn1 = 1;
-    }
-
-/*     Compute the eigenvector */
-
-    if (df >= 0.) {
-	cs = df + rt;
-	sgn2 = 1;
-    } else {
-	cs = df - rt;
-	sgn2 = -1;
-    }
-    acs = abs(cs);
-    if (acs > ab) {
-	ct = -tb / cs;
-	*sn1 = 1. / sqrt(ct * ct + 1.);
-	*cs1 = ct * *sn1;
-    } else {
-	if (ab == 0.) {
-	    *cs1 = 1.;
-	    *sn1 = 0.;
-	} else {
-	    tn = -cs / tb;
-	    *cs1 = 1. / sqrt(tn * tn + 1.);
-	    *sn1 = tn * *cs1;
-	}
-    }
-    if (sgn1 == sgn2) {
-	tn = *cs1;
-	*cs1 = -(*sn1);
-	*sn1 = tn;
-    }
-    return 0;
-
-/*     End of DLAEV2 */
-
-} /* dlaev2_ */

3rdparty/lapack/dlagtf.c

@@ -1,224 +0,0 @@
-/* dlagtf.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlagtf_(integer *n, doublereal *a, doublereal *lambda, 
-	doublereal *b, doublereal *c__, doublereal *tol, doublereal *d__, 
-	integer *in, integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1, d__2;
-
-    /* Local variables */
-    integer k;
-    doublereal tl, eps, piv1, piv2, temp, mult, scale1, scale2;
-    extern doublereal dlamch_(char *);
-    extern /* Subroutine */ int xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n */
-/*  tridiagonal matrix and lambda is a scalar, as */
-
-/*     T - lambda*I = PLU, */
-
-/*  where P is a permutation matrix, L is a unit lower tridiagonal matrix */
-/*  with at most one non-zero sub-diagonal elements per column and U is */
-/*  an upper triangular matrix with at most two non-zero super-diagonal */
-/*  elements per column. */
-
-/*  The factorization is obtained by Gaussian elimination with partial */
-/*  pivoting and implicit row scaling. */
-
-/*  The parameter LAMBDA is included in the routine so that DLAGTF may */
-/*  be used, in conjunction with DLAGTS, to obtain eigenvectors of T by */
-/*  inverse iteration. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix T. */
-
-/*  A       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, A must contain the diagonal elements of T. */
-
-/*          On exit, A is overwritten by the n diagonal elements of the */
-/*          upper triangular matrix U of the factorization of T. */
-
-/*  LAMBDA  (input) DOUBLE PRECISION */
-/*          On entry, the scalar lambda. */
-
-/*  B       (input/output) DOUBLE PRECISION array, dimension (N-1) */
-/*          On entry, B must contain the (n-1) super-diagonal elements of */
-/*          T. */
-
-/*          On exit, B is overwritten by the (n-1) super-diagonal */
-/*          elements of the matrix U of the factorization of T. */
-
-/*  C       (input/output) DOUBLE PRECISION array, dimension (N-1) */
-/*          On entry, C must contain the (n-1) sub-diagonal elements of */
-/*          T. */
-
-/*          On exit, C is overwritten by the (n-1) sub-diagonal elements */
-/*          of the matrix L of the factorization of T. */
-
-/*  TOL     (input) DOUBLE PRECISION */
-/*          On entry, a relative tolerance used to indicate whether or */
-/*          not the matrix (T - lambda*I) is nearly singular. TOL should */
-/*          normally be chose as approximately the largest relative error */
-/*          in the elements of T. For example, if the elements of T are */
-/*          correct to about 4 significant figures, then TOL should be */
-/*          set to about 5*10**(-4). If TOL is supplied as less than eps, */
-/*          where eps is the relative machine precision, then the value */
-/*          eps is used in place of TOL. */
-
-/*  D       (output) DOUBLE PRECISION array, dimension (N-2) */
-/*          On exit, D is overwritten by the (n-2) second super-diagonal */
-/*          elements of the matrix U of the factorization of T. */
-
-/*  IN      (output) INTEGER array, dimension (N) */
-/*          On exit, IN contains details of the permutation matrix P. If */
-/*          an interchange occurred at the kth step of the elimination, */
-/*          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) */
-/*          returns the smallest positive integer j such that */
-
-/*             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, */
-
-/*          where norm( A(j) ) denotes the sum of the absolute values of */
-/*          the jth row of the matrix A. If no such j exists then IN(n) */
-/*          is returned as zero. If IN(n) is returned as positive, then a */
-/*          diagonal element of U is small, indicating that */
-/*          (T - lambda*I) is singular or nearly singular, */
-
-/*  INFO    (output) INTEGER */
-/*          = 0   : successful exit */
-/*          .lt. 0: if INFO = -k, the kth argument had an illegal value */
-
-/* ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --in;
-    --d__;
-    --c__;
-    --b;
-    --a;
-
-    /* Function Body */
-    *info = 0;
-    if (*n < 0) {
-	*info = -1;
-	i__1 = -(*info);
-	xerbla_("DLAGTF", &i__1);
-	return 0;
-    }
-
-    if (*n == 0) {
-	return 0;
-    }
-
-    a[1] -= *lambda;
-    in[*n] = 0;
-    if (*n == 1) {
-	if (a[1] == 0.) {
-	    in[1] = 1;
-	}
-	return 0;
-    }
-
-    eps = dlamch_("Epsilon");
-
-    tl = max(*tol,eps);
-    scale1 = abs(a[1]) + abs(b[1]);
-    i__1 = *n - 1;
-    for (k = 1; k <= i__1; ++k) {
-	a[k + 1] -= *lambda;
-	scale2 = (d__1 = c__[k], abs(d__1)) + (d__2 = a[k + 1], abs(d__2));
-	if (k < *n - 1) {
-	    scale2 += (d__1 = b[k + 1], abs(d__1));
-	}
-	if (a[k] == 0.) {
-	    piv1 = 0.;
-	} else {
-	    piv1 = (d__1 = a[k], abs(d__1)) / scale1;
-	}
-	if (c__[k] == 0.) {
-	    in[k] = 0;
-	    piv2 = 0.;
-	    scale1 = scale2;
-	    if (k < *n - 1) {
-		d__[k] = 0.;
-	    }
-	} else {
-	    piv2 = (d__1 = c__[k], abs(d__1)) / scale2;
-	    if (piv2 <= piv1) {
-		in[k] = 0;
-		scale1 = scale2;
-		c__[k] /= a[k];
-		a[k + 1] -= c__[k] * b[k];
-		if (k < *n - 1) {
-		    d__[k] = 0.;
-		}
-	    } else {
-		in[k] = 1;
-		mult = a[k] / c__[k];
-		a[k] = c__[k];
-		temp = a[k + 1];
-		a[k + 1] = b[k] - mult * temp;
-		if (k < *n - 1) {
-		    d__[k] = b[k + 1];
-		    b[k + 1] = -mult * d__[k];
-		}
-		b[k] = temp;
-		c__[k] = mult;
-	    }
-	}
-	if (max(piv1,piv2) <= tl && in[*n] == 0) {
-	    in[*n] = k;
-	}
-/* L10: */
-    }
-    if ((d__1 = a[*n], abs(d__1)) <= scale1 * tl && in[*n] == 0) {
-	in[*n] = *n;
-    }
-
-    return 0;
-
-/*     End of DLAGTF */
-
-} /* dlagtf_ */

3rdparty/lapack/dlagts.c

@@ -1,351 +0,0 @@
-/* dlagts.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlagts_(integer *job, integer *n, doublereal *a, 
-	doublereal *b, doublereal *c__, doublereal *d__, integer *in, 
-	doublereal *y, doublereal *tol, integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1, d__2, d__3, d__4, d__5;
-
-    /* Builtin functions */
-    double d_sign(doublereal *, doublereal *);
-
-    /* Local variables */
-    integer k;
-    doublereal ak, eps, temp, pert, absak, sfmin;
-    extern doublereal dlamch_(char *);
-    extern /* Subroutine */ int xerbla_(char *, integer *);
-    doublereal bignum;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAGTS may be used to solve one of the systems of equations */
-
-/*     (T - lambda*I)*x = y   or   (T - lambda*I)'*x = y, */
-
-/*  where T is an n by n tridiagonal matrix, for x, following the */
-/*  factorization of (T - lambda*I) as */
-
-/*     (T - lambda*I) = P*L*U , */
-
-/*  by routine DLAGTF. The choice of equation to be solved is */
-/*  controlled by the argument JOB, and in each case there is an option */
-/*  to perturb zero or very small diagonal elements of U, this option */
-/*  being intended for use in applications such as inverse iteration. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  JOB     (input) INTEGER */
-/*          Specifies the job to be performed by DLAGTS as follows: */
-/*          =  1: The equations  (T - lambda*I)x = y  are to be solved, */
-/*                but diagonal elements of U are not to be perturbed. */
-/*          = -1: The equations  (T - lambda*I)x = y  are to be solved */
-/*                and, if overflow would otherwise occur, the diagonal */
-/*                elements of U are to be perturbed. See argument TOL */
-/*                below. */
-/*          =  2: The equations  (T - lambda*I)'x = y  are to be solved, */
-/*                but diagonal elements of U are not to be perturbed. */
-/*          = -2: The equations  (T - lambda*I)'x = y  are to be solved */
-/*                and, if overflow would otherwise occur, the diagonal */
-/*                elements of U are to be perturbed. See argument TOL */
-/*                below. */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix T. */
-
-/*  A       (input) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, A must contain the diagonal elements of U as */
-/*          returned from DLAGTF. */
-
-/*  B       (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          On entry, B must contain the first super-diagonal elements of */
-/*          U as returned from DLAGTF. */
-
-/*  C       (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          On entry, C must contain the sub-diagonal elements of L as */
-/*          returned from DLAGTF. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N-2) */
-/*          On entry, D must contain the second super-diagonal elements */
-/*          of U as returned from DLAGTF. */
-
-/*  IN      (input) INTEGER array, dimension (N) */
-/*          On entry, IN must contain details of the matrix P as returned */
-/*          from DLAGTF. */
-
-/*  Y       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the right hand side vector y. */
-/*          On exit, Y is overwritten by the solution vector x. */
-
-/*  TOL     (input/output) DOUBLE PRECISION */
-/*          On entry, with  JOB .lt. 0, TOL should be the minimum */
-/*          perturbation to be made to very small diagonal elements of U. */
-/*          TOL should normally be chosen as about eps*norm(U), where eps */
-/*          is the relative machine precision, but if TOL is supplied as */
-/*          non-positive, then it is reset to eps*max( abs( u(i,j) ) ). */
-/*          If  JOB .gt. 0  then TOL is not referenced. */
-
-/*          On exit, TOL is changed as described above, only if TOL is */
-/*          non-positive on entry. Otherwise TOL is unchanged. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0   : successful exit */
-/*          .lt. 0: if INFO = -i, the i-th argument had an illegal value */
-/*          .gt. 0: overflow would occur when computing the INFO(th) */
-/*                  element of the solution vector x. This can only occur */
-/*                  when JOB is supplied as positive and either means */
-/*                  that a diagonal element of U is very small, or that */
-/*                  the elements of the right-hand side vector y are very */
-/*                  large. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --y;
-    --in;
-    --d__;
-    --c__;
-    --b;
-    --a;
-
-    /* Function Body */
-    *info = 0;
-    if (abs(*job) > 2 || *job == 0) {
-	*info = -1;
-    } else if (*n < 0) {
-	*info = -2;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLAGTS", &i__1);
-	return 0;
-    }
-
-    if (*n == 0) {
-	return 0;
-    }
-
-    eps = dlamch_("Epsilon");
-    sfmin = dlamch_("Safe minimum");
-    bignum = 1. / sfmin;
-
-    if (*job < 0) {
-	if (*tol <= 0.) {
-	    *tol = abs(a[1]);
-	    if (*n > 1) {
-/* Computing MAX */
-		d__1 = *tol, d__2 = abs(a[2]), d__1 = max(d__1,d__2), d__2 = 
-			abs(b[1]);
-		*tol = max(d__1,d__2);
-	    }
-	    i__1 = *n;
-	    for (k = 3; k <= i__1; ++k) {
-/* Computing MAX */
-		d__4 = *tol, d__5 = (d__1 = a[k], abs(d__1)), d__4 = max(d__4,
-			d__5), d__5 = (d__2 = b[k - 1], abs(d__2)), d__4 = 
-			max(d__4,d__5), d__5 = (d__3 = d__[k - 2], abs(d__3));
-		*tol = max(d__4,d__5);
-/* L10: */
-	    }
-	    *tol *= eps;
-	    if (*tol == 0.) {
-		*tol = eps;
-	    }
-	}
-    }
-
-    if (abs(*job) == 1) {
-	i__1 = *n;
-	for (k = 2; k <= i__1; ++k) {
-	    if (in[k - 1] == 0) {
-		y[k] -= c__[k - 1] * y[k - 1];
-	    } else {
-		temp = y[k - 1];
-		y[k - 1] = y[k];
-		y[k] = temp - c__[k - 1] * y[k];
-	    }
-/* L20: */
-	}
-	if (*job == 1) {
-	    for (k = *n; k >= 1; --k) {
-		if (k <= *n - 2) {
-		    temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2];
-		} else if (k == *n - 1) {
-		    temp = y[k] - b[k] * y[k + 1];
-		} else {
-		    temp = y[k];
-		}
-		ak = a[k];
-		absak = abs(ak);
-		if (absak < 1.) {
-		    if (absak < sfmin) {
-			if (absak == 0. || abs(temp) * sfmin > absak) {
-			    *info = k;
-			    return 0;
-			} else {
-			    temp *= bignum;
-			    ak *= bignum;
-			}
-		    } else if (abs(temp) > absak * bignum) {
-			*info = k;
-			return 0;
-		    }
-		}
-		y[k] = temp / ak;
-/* L30: */
-	    }
-	} else {
-	    for (k = *n; k >= 1; --k) {
-		if (k <= *n - 2) {
-		    temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2];
-		} else if (k == *n - 1) {
-		    temp = y[k] - b[k] * y[k + 1];
-		} else {
-		    temp = y[k];
-		}
-		ak = a[k];
-		pert = d_sign(tol, &ak);
-L40:
-		absak = abs(ak);
-		if (absak < 1.) {
-		    if (absak < sfmin) {
-			if (absak == 0. || abs(temp) * sfmin > absak) {
-			    ak += pert;
-			    pert *= 2;
-			    goto L40;
-			} else {
-			    temp *= bignum;
-			    ak *= bignum;
-			}
-		    } else if (abs(temp) > absak * bignum) {
-			ak += pert;
-			pert *= 2;
-			goto L40;
-		    }
-		}
-		y[k] = temp / ak;
-/* L50: */
-	    }
-	}
-    } else {
-
-/*        Come to here if  JOB = 2 or -2 */
-
-	if (*job == 2) {
-	    i__1 = *n;
-	    for (k = 1; k <= i__1; ++k) {
-		if (k >= 3) {
-		    temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2];
-		} else if (k == 2) {
-		    temp = y[k] - b[k - 1] * y[k - 1];
-		} else {
-		    temp = y[k];
-		}
-		ak = a[k];
-		absak = abs(ak);
-		if (absak < 1.) {
-		    if (absak < sfmin) {
-			if (absak == 0. || abs(temp) * sfmin > absak) {
-			    *info = k;
-			    return 0;
-			} else {
-			    temp *= bignum;
-			    ak *= bignum;
-			}
-		    } else if (abs(temp) > absak * bignum) {
-			*info = k;
-			return 0;
-		    }
-		}
-		y[k] = temp / ak;
-/* L60: */
-	    }
-	} else {
-	    i__1 = *n;
-	    for (k = 1; k <= i__1; ++k) {
-		if (k >= 3) {
-		    temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2];
-		} else if (k == 2) {
-		    temp = y[k] - b[k - 1] * y[k - 1];
-		} else {
-		    temp = y[k];
-		}
-		ak = a[k];
-		pert = d_sign(tol, &ak);
-L70:
-		absak = abs(ak);
-		if (absak < 1.) {
-		    if (absak < sfmin) {
-			if (absak == 0. || abs(temp) * sfmin > absak) {
-			    ak += pert;
-			    pert *= 2;
-			    goto L70;
-			} else {
-			    temp *= bignum;
-			    ak *= bignum;
-			}
-		    } else if (abs(temp) > absak * bignum) {
-			ak += pert;
-			pert *= 2;
-			goto L70;
-		    }
-		}
-		y[k] = temp / ak;
-/* L80: */
-	    }
-	}
-
-	for (k = *n; k >= 2; --k) {
-	    if (in[k - 1] == 0) {
-		y[k - 1] -= c__[k - 1] * y[k];
-	    } else {
-		temp = y[k - 1];
-		y[k - 1] = y[k];
-		y[k] = temp - c__[k - 1] * y[k];
-	    }
-/* L90: */
-	}
-    }
-
-/*     End of DLAGTS */
-
-    return 0;
-} /* dlagts_ */

3rdparty/lapack/dlaisnan.c

@@ -1,58 +0,0 @@
-/* dlaisnan.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-logical dlaisnan_(doublereal *din1, doublereal *din2)
-{
-    /* System generated locals */
-    logical ret_val;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  This routine is not for general use.  It exists solely to avoid */
-/*  over-optimization in DISNAN. */
-
-/*  DLAISNAN checks for NaNs by comparing its two arguments for */
-/*  inequality.  NaN is the only floating-point value where NaN != NaN */
-/*  returns .TRUE.  To check for NaNs, pass the same variable as both */
-/*  arguments. */
-
-/*  A compiler must assume that the two arguments are */
-/*  not the same variable, and the test will not be optimized away. */
-/*  Interprocedural or whole-program optimization may delete this */
-/*  test.  The ISNAN functions will be replaced by the correct */
-/*  Fortran 03 intrinsic once the intrinsic is widely available. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  DIN1     (input) DOUBLE PRECISION */
-/*  DIN2     (input) DOUBLE PRECISION */
-/*          Two numbers to compare for inequality. */
-
-/*  ===================================================================== */
-
-/*  .. Executable Statements .. */
-    ret_val = *din1 != *din2;
-    return ret_val;
-} /* dlaisnan_ */

3rdparty/lapack/dlals0.c

@@ -1,473 +0,0 @@
-/* dlals0.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static doublereal c_b5 = -1.;
-static integer c__1 = 1;
-static doublereal c_b11 = 1.;
-static doublereal c_b13 = 0.;
-static integer c__0 = 0;
-
-/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr, 
-	integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal 
-	*bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, 
-	integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *
-	poles, doublereal *difl, doublereal *difr, doublereal *z__, integer *
-	k, doublereal *c__, doublereal *s, doublereal *work, integer *info)
-{
-    /* System generated locals */
-    integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, 
-	    difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1, 
-	    poles_offset, i__1, i__2;
-    doublereal d__1;
-
-    /* Local variables */
-    integer i__, j, m, n;
-    doublereal dj;
-    integer nlp1;
-    doublereal temp;
-    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *);
-    extern doublereal dnrm2_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
-	    integer *);
-    doublereal diflj, difrj, dsigj;
-    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
-	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
-	    doublereal *, doublereal *, integer *), dcopy_(integer *, 
-	    doublereal *, integer *, doublereal *, integer *);
-    extern doublereal dlamc3_(doublereal *, doublereal *);
-    extern /* Subroutine */ int dlascl_(char *, integer *, integer *, 
-	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
-	    integer *, integer *), dlacpy_(char *, integer *, integer 
-	    *, doublereal *, integer *, doublereal *, integer *), 
-	    xerbla_(char *, integer *);
-    doublereal dsigjp;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLALS0 applies back the multiplying factors of either the left or the */
-/*  right singular vector matrix of a diagonal matrix appended by a row */
-/*  to the right hand side matrix B in solving the least squares problem */
-/*  using the divide-and-conquer SVD approach. */
-
-/*  For the left singular vector matrix, three types of orthogonal */
-/*  matrices are involved: */
-
-/*  (1L) Givens rotations: the number of such rotations is GIVPTR; the */
-/*       pairs of columns/rows they were applied to are stored in GIVCOL; */
-/*       and the C- and S-values of these rotations are stored in GIVNUM. */
-
-/*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */
-/*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the */
-/*       J-th row. */
-
-/*  (3L) The left singular vector matrix of the remaining matrix. */
-
-/*  For the right singular vector matrix, four types of orthogonal */
-/*  matrices are involved: */
-
-/*  (1R) The right singular vector matrix of the remaining matrix. */
-
-/*  (2R) If SQRE = 1, one extra Givens rotation to generate the right */
-/*       null space. */
-
-/*  (3R) The inverse transformation of (2L). */
-
-/*  (4R) The inverse transformation of (1L). */
-
-/*  Arguments */
-/*  ========= */
-
-/*  ICOMPQ (input) INTEGER */
-/*         Specifies whether singular vectors are to be computed in */
-/*         factored form: */
-/*         = 0: Left singular vector matrix. */
-/*         = 1: Right singular vector matrix. */
-
-/*  NL     (input) INTEGER */
-/*         The row dimension of the upper block. NL >= 1. */
-
-/*  NR     (input) INTEGER */
-/*         The row dimension of the lower block. NR >= 1. */
-
-/*  SQRE   (input) INTEGER */
-/*         = 0: the lower block is an NR-by-NR square matrix. */
-/*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
-
-/*         The bidiagonal matrix has row dimension N = NL + NR + 1, */
-/*         and column dimension M = N + SQRE. */
-
-/*  NRHS   (input) INTEGER */
-/*         The number of columns of B and BX. NRHS must be at least 1. */
-
-/*  B      (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) */
-/*         On input, B contains the right hand sides of the least */
-/*         squares problem in rows 1 through M. On output, B contains */
-/*         the solution X in rows 1 through N. */
-
-/*  LDB    (input) INTEGER */
-/*         The leading dimension of B. LDB must be at least */
-/*         max(1,MAX( M, N ) ). */
-
-/*  BX     (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */
-
-/*  LDBX   (input) INTEGER */
-/*         The leading dimension of BX. */
-
-/*  PERM   (input) INTEGER array, dimension ( N ) */
-/*         The permutations (from deflation and sorting) applied */
-/*         to the two blocks. */
-
-/*  GIVPTR (input) INTEGER */
-/*         The number of Givens rotations which took place in this */
-/*         subproblem. */
-
-/*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) */
-/*         Each pair of numbers indicates a pair of rows/columns */
-/*         involved in a Givens rotation. */
-
-/*  LDGCOL (input) INTEGER */
-/*         The leading dimension of GIVCOL, must be at least N. */
-
-/*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
-/*         Each number indicates the C or S value used in the */
-/*         corresponding Givens rotation. */
-
-/*  LDGNUM (input) INTEGER */
-/*         The leading dimension of arrays DIFR, POLES and */
-/*         GIVNUM, must be at least K. */
-
-/*  POLES  (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
-/*         On entry, POLES(1:K, 1) contains the new singular */
-/*         values obtained from solving the secular equation, and */
-/*         POLES(1:K, 2) is an array containing the poles in the secular */
-/*         equation. */
-
-/*  DIFL   (input) DOUBLE PRECISION array, dimension ( K ). */
-/*         On entry, DIFL(I) is the distance between I-th updated */
-/*         (undeflated) singular value and the I-th (undeflated) old */
-/*         singular value. */
-
-/*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). */
-/*         On entry, DIFR(I, 1) contains the distances between I-th */
-/*         updated (undeflated) singular value and the I+1-th */
-/*         (undeflated) old singular value. And DIFR(I, 2) is the */
-/*         normalizing factor for the I-th right singular vector. */
-
-/*  Z      (input) DOUBLE PRECISION array, dimension ( K ) */
-/*         Contain the components of the deflation-adjusted updating row */
-/*         vector. */
-
-/*  K      (input) INTEGER */
-/*         Contains the dimension of the non-deflated matrix, */
-/*         This is the order of the related secular equation. 1 <= K <=N. */
-
-/*  C      (input) DOUBLE PRECISION */
-/*         C contains garbage if SQRE =0 and the C-value of a Givens */
-/*         rotation related to the right null space if SQRE = 1. */
-
-/*  S      (input) DOUBLE PRECISION */
-/*         S contains garbage if SQRE =0 and the S-value of a Givens */
-/*         rotation related to the right null space if SQRE = 1. */
-
-/*  WORK   (workspace) DOUBLE PRECISION array, dimension ( K ) */
-
-/*  INFO   (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Ming Gu and Ren-Cang Li, Computer Science Division, University of */
-/*       California at Berkeley, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-    bx_dim1 = *ldbx;
-    bx_offset = 1 + bx_dim1;
-    bx -= bx_offset;
-    --perm;
-    givcol_dim1 = *ldgcol;
-    givcol_offset = 1 + givcol_dim1;
-    givcol -= givcol_offset;
-    difr_dim1 = *ldgnum;
-    difr_offset = 1 + difr_dim1;
-    difr -= difr_offset;
-    poles_dim1 = *ldgnum;
-    poles_offset = 1 + poles_dim1;
-    poles -= poles_offset;
-    givnum_dim1 = *ldgnum;
-    givnum_offset = 1 + givnum_dim1;
-    givnum -= givnum_offset;
-    --difl;
-    --z__;
-    --work;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*icompq < 0 || *icompq > 1) {
-	*info = -1;
-    } else if (*nl < 1) {
-	*info = -2;
-    } else if (*nr < 1) {
-	*info = -3;
-    } else if (*sqre < 0 || *sqre > 1) {
-	*info = -4;
-    }
-
-    n = *nl + *nr + 1;
-
-    if (*nrhs < 1) {
-	*info = -5;
-    } else if (*ldb < n) {
-	*info = -7;
-    } else if (*ldbx < n) {
-	*info = -9;
-    } else if (*givptr < 0) {
-	*info = -11;
-    } else if (*ldgcol < n) {
-	*info = -13;
-    } else if (*ldgnum < n) {
-	*info = -15;
-    } else if (*k < 1) {
-	*info = -20;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLALS0", &i__1);
-	return 0;
-    }
-
-    m = n + *sqre;
-    nlp1 = *nl + 1;
-
-    if (*icompq == 0) {
-
-/*        Apply back orthogonal transformations from the left. */
-
-/*        Step (1L): apply back the Givens rotations performed. */
-
-	i__1 = *givptr;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
-		    b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + 
-		    (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]);
-/* L10: */
-	}
-
-/*        Step (2L): permute rows of B. */
-
-	dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx);
-	i__1 = n;
-	for (i__ = 2; i__ <= i__1; ++i__) {
-	    dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], 
-		    ldbx);
-/* L20: */
-	}
-
-/*        Step (3L): apply the inverse of the left singular vector */
-/*        matrix to BX. */
-
-	if (*k == 1) {
-	    dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
-	    if (z__[1] < 0.) {
-		dscal_(nrhs, &c_b5, &b[b_offset], ldb);
-	    }
-	} else {
-	    i__1 = *k;
-	    for (j = 1; j <= i__1; ++j) {
-		diflj = difl[j];
-		dj = poles[j + poles_dim1];
-		dsigj = -poles[j + (poles_dim1 << 1)];
-		if (j < *k) {
-		    difrj = -difr[j + difr_dim1];
-		    dsigjp = -poles[j + 1 + (poles_dim1 << 1)];
-		}
-		if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) {
-		    work[j] = 0.;
-		} else {
-		    work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj /
-			     (poles[j + (poles_dim1 << 1)] + dj);
-		}
-		i__2 = j - 1;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == 
-			    0.) {
-			work[i__] = 0.;
-		    } else {
-			work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] 
-				/ (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
-				dsigj) - diflj) / (poles[i__ + (poles_dim1 << 
-				1)] + dj);
-		    }
-/* L30: */
-		}
-		i__2 = *k;
-		for (i__ = j + 1; i__ <= i__2; ++i__) {
-		    if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == 
-			    0.) {
-			work[i__] = 0.;
-		    } else {
-			work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] 
-				/ (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
-				dsigjp) + difrj) / (poles[i__ + (poles_dim1 <<
-				 1)] + dj);
-		    }
-/* L40: */
-		}
-		work[1] = -1.;
-		temp = dnrm2_(k, &work[1], &c__1);
-		dgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], &
-			c__1, &c_b13, &b[j + b_dim1], ldb);
-		dlascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j + 
-			b_dim1], ldb, info);
-/* L50: */
-	    }
-	}
-
-/*        Move the deflated rows of BX to B also. */
-
-	if (*k < max(m,n)) {
-	    i__1 = n - *k;
-	    dlacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 
-		    + b_dim1], ldb);
-	}
-    } else {
-
-/*        Apply back the right orthogonal transformations. */
-
-/*        Step (1R): apply back the new right singular vector matrix */
-/*        to B. */
-
-	if (*k == 1) {
-	    dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
-	} else {
-	    i__1 = *k;
-	    for (j = 1; j <= i__1; ++j) {
-		dsigj = poles[j + (poles_dim1 << 1)];
-		if (z__[j] == 0.) {
-		    work[j] = 0.;
-		} else {
-		    work[j] = -z__[j] / difl[j] / (dsigj + poles[j + 
-			    poles_dim1]) / difr[j + (difr_dim1 << 1)];
-		}
-		i__2 = j - 1;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    if (z__[j] == 0.) {
-			work[i__] = 0.;
-		    } else {
-			d__1 = -poles[i__ + 1 + (poles_dim1 << 1)];
-			work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[
-				i__ + difr_dim1]) / (dsigj + poles[i__ + 
-				poles_dim1]) / difr[i__ + (difr_dim1 << 1)];
-		    }
-/* L60: */
-		}
-		i__2 = *k;
-		for (i__ = j + 1; i__ <= i__2; ++i__) {
-		    if (z__[j] == 0.) {
-			work[i__] = 0.;
-		    } else {
-			d__1 = -poles[i__ + (poles_dim1 << 1)];
-			work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[
-				i__]) / (dsigj + poles[i__ + poles_dim1]) / 
-				difr[i__ + (difr_dim1 << 1)];
-		    }
-/* L70: */
-		}
-		dgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &
-			c__1, &c_b13, &bx[j + bx_dim1], ldbx);
-/* L80: */
-	    }
-	}
-
-/*        Step (2R): if SQRE = 1, apply back the rotation that is */
-/*        related to the right null space of the subproblem. */
-
-	if (*sqre == 1) {
-	    dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx);
-	    drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, 
-		    s);
-	}
-	if (*k < max(m,n)) {
-	    i__1 = n - *k;
-	    dlacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + 
-		    bx_dim1], ldbx);
-	}
-
-/*        Step (3R): permute rows of B. */
-
-	dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb);
-	if (*sqre == 1) {
-	    dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb);
-	}
-	i__1 = n;
-	for (i__ = 2; i__ <= i__1; ++i__) {
-	    dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], 
-		    ldb);
-/* L90: */
-	}
-
-/*        Step (4R): apply back the Givens rotations performed. */
-
-	for (i__ = *givptr; i__ >= 1; --i__) {
-	    d__1 = -givnum[i__ + givnum_dim1];
-	    drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
-		    b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + 
-		    (givnum_dim1 << 1)], &d__1);
-/* L100: */
-	}
-    }
-
-    return 0;
-
-/*     End of DLALS0 */
-
-} /* dlals0_ */

3rdparty/lapack/dlalsa.c

@@ -1,456 +0,0 @@
-/* dlalsa.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static doublereal c_b7 = 1.;
-static doublereal c_b8 = 0.;
-static integer c__2 = 2;
-
-/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n, 
-	integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *
-	ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k, 
-	doublereal *difl, doublereal *difr, doublereal *z__, doublereal *
-	poles, integer *givptr, integer *givcol, integer *ldgcol, integer *
-	perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *
-	work, integer *iwork, integer *info)
-{
-    /* System generated locals */
-    integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, 
-	    b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1, 
-	    difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset,
-	     u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1, 
-	    i__2;
-
-    /* Builtin functions */
-    integer pow_ii(integer *, integer *);
-
-    /* Local variables */
-    integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1, 
-	    nlp1, lvl2, nrp1, nlvl, sqre;
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *);
-    integer inode, ndiml, ndimr;
-    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *), dlals0_(integer *, integer *, integer *, 
-	     integer *, integer *, doublereal *, integer *, doublereal *, 
-	    integer *, integer *, integer *, integer *, integer *, doublereal 
-	    *, integer *, doublereal *, doublereal *, doublereal *, 
-	    doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
-	     integer *), dlasdt_(integer *, integer *, integer *, integer *, 
-	    integer *, integer *, integer *), xerbla_(char *, integer *);
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLALSA is an itermediate step in solving the least squares problem */
-/*  by computing the SVD of the coefficient matrix in compact form (The */
-/*  singular vectors are computed as products of simple orthorgonal */
-/*  matrices.). */
-
-/*  If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector */
-/*  matrix of an upper bidiagonal matrix to the right hand side; and if */
-/*  ICOMPQ = 1, DLALSA applies the right singular vector matrix to the */
-/*  right hand side. The singular vector matrices were generated in */
-/*  compact form by DLALSA. */
-
-/*  Arguments */
-/*  ========= */
-
-
-/*  ICOMPQ (input) INTEGER */
-/*         Specifies whether the left or the right singular vector */
-/*         matrix is involved. */
-/*         = 0: Left singular vector matrix */
-/*         = 1: Right singular vector matrix */
-
-/*  SMLSIZ (input) INTEGER */
-/*         The maximum size of the subproblems at the bottom of the */
-/*         computation tree. */
-
-/*  N      (input) INTEGER */
-/*         The row and column dimensions of the upper bidiagonal matrix. */
-
-/*  NRHS   (input) INTEGER */
-/*         The number of columns of B and BX. NRHS must be at least 1. */
-
-/*  B      (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) */
-/*         On input, B contains the right hand sides of the least */
-/*         squares problem in rows 1 through M. */
-/*         On output, B contains the solution X in rows 1 through N. */
-
-/*  LDB    (input) INTEGER */
-/*         The leading dimension of B in the calling subprogram. */
-/*         LDB must be at least max(1,MAX( M, N ) ). */
-
-/*  BX     (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */
-/*         On exit, the result of applying the left or right singular */
-/*         vector matrix to B. */
-
-/*  LDBX   (input) INTEGER */
-/*         The leading dimension of BX. */
-
-/*  U      (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). */
-/*         On entry, U contains the left singular vector matrices of all */
-/*         subproblems at the bottom level. */
-
-/*  LDU    (input) INTEGER, LDU = > N. */
-/*         The leading dimension of arrays U, VT, DIFL, DIFR, */
-/*         POLES, GIVNUM, and Z. */
-
-/*  VT     (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). */
-/*         On entry, VT' contains the right singular vector matrices of */
-/*         all subproblems at the bottom level. */
-
-/*  K      (input) INTEGER array, dimension ( N ). */
-
-/*  DIFL   (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */
-/*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */
-
-/*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
-/*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */
-/*         distances between singular values on the I-th level and */
-/*         singular values on the (I -1)-th level, and DIFR(*, 2 * I) */
-/*         record the normalizing factors of the right singular vectors */
-/*         matrices of subproblems on I-th level. */
-
-/*  Z      (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */
-/*         On entry, Z(1, I) contains the components of the deflation- */
-/*         adjusted updating row vector for subproblems on the I-th */
-/*         level. */
-
-/*  POLES  (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
-/*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */
-/*         singular values involved in the secular equations on the I-th */
-/*         level. */
-
-/*  GIVPTR (input) INTEGER array, dimension ( N ). */
-/*         On entry, GIVPTR( I ) records the number of Givens */
-/*         rotations performed on the I-th problem on the computation */
-/*         tree. */
-
-/*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */
-/*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */
-/*         locations of Givens rotations performed on the I-th level on */
-/*         the computation tree. */
-
-/*  LDGCOL (input) INTEGER, LDGCOL = > N. */
-/*         The leading dimension of arrays GIVCOL and PERM. */
-
-/*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ). */
-/*         On entry, PERM(*, I) records permutations done on the I-th */
-/*         level of the computation tree. */
-
-/*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
-/*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */
-/*         values of Givens rotations performed on the I-th level on the */
-/*         computation tree. */
-
-/*  C      (input) DOUBLE PRECISION array, dimension ( N ). */
-/*         On entry, if the I-th subproblem is not square, */
-/*         C( I ) contains the C-value of a Givens rotation related to */
-/*         the right null space of the I-th subproblem. */
-
-/*  S      (input) DOUBLE PRECISION array, dimension ( N ). */
-/*         On entry, if the I-th subproblem is not square, */
-/*         S( I ) contains the S-value of a Givens rotation related to */
-/*         the right null space of the I-th subproblem. */
-
-/*  WORK   (workspace) DOUBLE PRECISION array. */
-/*         The dimension must be at least N. */
-
-/*  IWORK  (workspace) INTEGER array. */
-/*         The dimension must be at least 3 * N */
-
-/*  INFO   (output) INTEGER */
-/*          = 0:  successful exit. */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Ming Gu and Ren-Cang Li, Computer Science Division, University of */
-/*       California at Berkeley, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-    bx_dim1 = *ldbx;
-    bx_offset = 1 + bx_dim1;
-    bx -= bx_offset;
-    givnum_dim1 = *ldu;
-    givnum_offset = 1 + givnum_dim1;
-    givnum -= givnum_offset;
-    poles_dim1 = *ldu;
-    poles_offset = 1 + poles_dim1;
-    poles -= poles_offset;
-    z_dim1 = *ldu;
-    z_offset = 1 + z_dim1;
-    z__ -= z_offset;
-    difr_dim1 = *ldu;
-    difr_offset = 1 + difr_dim1;
-    difr -= difr_offset;
-    difl_dim1 = *ldu;
-    difl_offset = 1 + difl_dim1;
-    difl -= difl_offset;
-    vt_dim1 = *ldu;
-    vt_offset = 1 + vt_dim1;
-    vt -= vt_offset;
-    u_dim1 = *ldu;
-    u_offset = 1 + u_dim1;
-    u -= u_offset;
-    --k;
-    --givptr;
-    perm_dim1 = *ldgcol;
-    perm_offset = 1 + perm_dim1;
-    perm -= perm_offset;
-    givcol_dim1 = *ldgcol;
-    givcol_offset = 1 + givcol_dim1;
-    givcol -= givcol_offset;
-    --c__;
-    --s;
-    --work;
-    --iwork;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*icompq < 0 || *icompq > 1) {
-	*info = -1;
-    } else if (*smlsiz < 3) {
-	*info = -2;
-    } else if (*n < *smlsiz) {
-	*info = -3;
-    } else if (*nrhs < 1) {
-	*info = -4;
-    } else if (*ldb < *n) {
-	*info = -6;
-    } else if (*ldbx < *n) {
-	*info = -8;
-    } else if (*ldu < *n) {
-	*info = -10;
-    } else if (*ldgcol < *n) {
-	*info = -19;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLALSA", &i__1);
-	return 0;
-    }
-
-/*     Book-keeping and  setting up the computation tree. */
-
-    inode = 1;
-    ndiml = inode + *n;
-    ndimr = ndiml + *n;
-
-    dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], 
-	    smlsiz);
-
-/*     The following code applies back the left singular vector factors. */
-/*     For applying back the right singular vector factors, go to 50. */
-
-    if (*icompq == 1) {
-	goto L50;
-    }
-
-/*     The nodes on the bottom level of the tree were solved */
-/*     by DLASDQ. The corresponding left and right singular vector */
-/*     matrices are in explicit form. First apply back the left */
-/*     singular vector matrices. */
-
-    ndb1 = (nd + 1) / 2;
-    i__1 = nd;
-    for (i__ = ndb1; i__ <= i__1; ++i__) {
-
-/*        IC : center row of each node */
-/*        NL : number of rows of left  subproblem */
-/*        NR : number of rows of right subproblem */
-/*        NLF: starting row of the left   subproblem */
-/*        NRF: starting row of the right  subproblem */
-
-	i1 = i__ - 1;
-	ic = iwork[inode + i1];
-	nl = iwork[ndiml + i1];
-	nr = iwork[ndimr + i1];
-	nlf = ic - nl;
-	nrf = ic + 1;
-	dgemm_("T", "N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf 
-		+ b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx);
-	dgemm_("T", "N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf 
-		+ b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx);
-/* L10: */
-    }
-
-/*     Next copy the rows of B that correspond to unchanged rows */
-/*     in the bidiagonal matrix to BX. */
-
-    i__1 = nd;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	ic = iwork[inode + i__ - 1];
-	dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx);
-/* L20: */
-    }
-
-/*     Finally go through the left singular vector matrices of all */
-/*     the other subproblems bottom-up on the tree. */
-
-    j = pow_ii(&c__2, &nlvl);
-    sqre = 0;
-
-    for (lvl = nlvl; lvl >= 1; --lvl) {
-	lvl2 = (lvl << 1) - 1;
-
-/*        find the first node LF and last node LL on */
-/*        the current level LVL */
-
-	if (lvl == 1) {
-	    lf = 1;
-	    ll = 1;
-	} else {
-	    i__1 = lvl - 1;
-	    lf = pow_ii(&c__2, &i__1);
-	    ll = (lf << 1) - 1;
-	}
-	i__1 = ll;
-	for (i__ = lf; i__ <= i__1; ++i__) {
-	    im1 = i__ - 1;
-	    ic = iwork[inode + im1];
-	    nl = iwork[ndiml + im1];
-	    nr = iwork[ndimr + im1];
-	    nlf = ic - nl;
-	    nrf = ic + 1;
-	    --j;
-	    dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &
-		    b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], &
-		    givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
-		    givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
-		     poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + 
-		    lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
-		    j], &s[j], &work[1], info);
-/* L30: */
-	}
-/* L40: */
-    }
-    goto L90;
-
-/*     ICOMPQ = 1: applying back the right singular vector factors. */
-
-L50:
-
-/*     First now go through the right singular vector matrices of all */
-/*     the tree nodes top-down. */
-
-    j = 0;
-    i__1 = nlvl;
-    for (lvl = 1; lvl <= i__1; ++lvl) {
-	lvl2 = (lvl << 1) - 1;
-
-/*        Find the first node LF and last node LL on */
-/*        the current level LVL. */
-
-	if (lvl == 1) {
-	    lf = 1;
-	    ll = 1;
-	} else {
-	    i__2 = lvl - 1;
-	    lf = pow_ii(&c__2, &i__2);
-	    ll = (lf << 1) - 1;
-	}
-	i__2 = lf;
-	for (i__ = ll; i__ >= i__2; --i__) {
-	    im1 = i__ - 1;
-	    ic = iwork[inode + im1];
-	    nl = iwork[ndiml + im1];
-	    nr = iwork[ndimr + im1];
-	    nlf = ic - nl;
-	    nrf = ic + 1;
-	    if (i__ == ll) {
-		sqre = 0;
-	    } else {
-		sqre = 1;
-	    }
-	    ++j;
-	    dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[
-		    nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], &
-		    givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
-		    givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
-		     poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + 
-		    lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
-		    j], &s[j], &work[1], info);
-/* L60: */
-	}
-/* L70: */
-    }
-
-/*     The nodes on the bottom level of the tree were solved */
-/*     by DLASDQ. The corresponding right singular vector */
-/*     matrices are in explicit form. Apply them back. */
-
-    ndb1 = (nd + 1) / 2;
-    i__1 = nd;
-    for (i__ = ndb1; i__ <= i__1; ++i__) {
-	i1 = i__ - 1;
-	ic = iwork[inode + i1];
-	nl = iwork[ndiml + i1];
-	nr = iwork[ndimr + i1];
-	nlp1 = nl + 1;
-	if (i__ == nd) {
-	    nrp1 = nr;
-	} else {
-	    nrp1 = nr + 1;
-	}
-	nlf = ic - nl;
-	nrf = ic + 1;
-	dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, &
-		b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx);
-	dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, &
-		b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx);
-/* L80: */
-    }
-
-L90:
-
-    return 0;
-
-/*     End of DLALSA */
-
-} /* dlalsa_ */

3rdparty/lapack/dlalsd.c

@@ -1,529 +0,0 @@
-/* dlalsd.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static doublereal c_b6 = 0.;
-static integer c__0 = 0;
-static doublereal c_b11 = 1.;
-
-/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer 
-	*nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb, 
-	doublereal *rcond, integer *rank, doublereal *work, integer *iwork, 
-	integer *info)
-{
-    /* System generated locals */
-    integer b_dim1, b_offset, i__1, i__2;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double log(doublereal), d_sign(doublereal *, doublereal *);
-
-    /* Local variables */
-    integer c__, i__, j, k;
-    doublereal r__;
-    integer s, u, z__;
-    doublereal cs;
-    integer bx;
-    doublereal sn;
-    integer st, vt, nm1, st1;
-    doublereal eps;
-    integer iwk;
-    doublereal tol;
-    integer difl, difr;
-    doublereal rcnd;
-    integer perm, nsub;
-    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *);
-    integer nlvl, sqre, bxst;
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *),
-	     dcopy_(integer *, doublereal *, integer *, doublereal *, integer 
-	    *);
-    integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
-    extern doublereal dlamch_(char *);
-    extern /* Subroutine */ int dlasda_(integer *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, doublereal *, integer *, 
-	    doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
-	     doublereal *, integer *, integer *, integer *, integer *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, integer *, 
-	     integer *), dlalsa_(integer *, integer *, integer *, integer *, 
-	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
-	    doublereal *, doublereal *, integer *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, doublereal *, doublereal *, 
-	     integer *, integer *), dlascl_(char *, integer *, integer *, 
-	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
-	    integer *, integer *);
-    extern integer idamax_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer 
-	    *, integer *, integer *, doublereal *, doublereal *, doublereal *, 
-	     integer *, doublereal *, integer *, doublereal *, integer *, 
-	    doublereal *, integer *), dlacpy_(char *, integer *, 
-	    integer *, doublereal *, integer *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *, 
-	    doublereal *, doublereal *), dlaset_(char *, integer *, integer *, 
-	     doublereal *, doublereal *, doublereal *, integer *), 
-	    xerbla_(char *, integer *);
-    integer givcol;
-    extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
-    extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, 
-	    integer *);
-    doublereal orgnrm;
-    integer givnum, givptr, smlszp;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLALSD uses the singular value decomposition of A to solve the least */
-/*  squares problem of finding X to minimize the Euclidean norm of each */
-/*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
-/*  are N-by-NRHS. The solution X overwrites B. */
-
-/*  The singular values of A smaller than RCOND times the largest */
-/*  singular value are treated as zero in solving the least squares */
-/*  problem; in this case a minimum norm solution is returned. */
-/*  The actual singular values are returned in D in ascending order. */
-
-/*  This code makes very mild assumptions about floating point */
-/*  arithmetic. It will work on machines with a guard digit in */
-/*  add/subtract, or on those binary machines without guard digits */
-/*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
-/*  It could conceivably fail on hexadecimal or decimal machines */
-/*  without guard digits, but we know of none. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  UPLO   (input) CHARACTER*1 */
-/*         = 'U': D and E define an upper bidiagonal matrix. */
-/*         = 'L': D and E define a  lower bidiagonal matrix. */
-
-/*  SMLSIZ (input) INTEGER */
-/*         The maximum size of the subproblems at the bottom of the */
-/*         computation tree. */
-
-/*  N      (input) INTEGER */
-/*         The dimension of the  bidiagonal matrix.  N >= 0. */
-
-/*  NRHS   (input) INTEGER */
-/*         The number of columns of B. NRHS must be at least 1. */
-
-/*  D      (input/output) DOUBLE PRECISION array, dimension (N) */
-/*         On entry D contains the main diagonal of the bidiagonal */
-/*         matrix. On exit, if INFO = 0, D contains its singular values. */
-
-/*  E      (input/output) DOUBLE PRECISION array, dimension (N-1) */
-/*         Contains the super-diagonal entries of the bidiagonal matrix. */
-/*         On exit, E has been destroyed. */
-
-/*  B      (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
-/*         On input, B contains the right hand sides of the least */
-/*         squares problem. On output, B contains the solution X. */
-
-/*  LDB    (input) INTEGER */
-/*         The leading dimension of B in the calling subprogram. */
-/*         LDB must be at least max(1,N). */
-
-/*  RCOND  (input) DOUBLE PRECISION */
-/*         The singular values of A less than or equal to RCOND times */
-/*         the largest singular value are treated as zero in solving */
-/*         the least squares problem. If RCOND is negative, */
-/*         machine precision is used instead. */
-/*         For example, if diag(S)*X=B were the least squares problem, */
-/*         where diag(S) is a diagonal matrix of singular values, the */
-/*         solution would be X(i) = B(i) / S(i) if S(i) is greater than */
-/*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
-/*         RCOND*max(S). */
-
-/*  RANK   (output) INTEGER */
-/*         The number of singular values of A greater than RCOND times */
-/*         the largest singular value. */
-
-/*  WORK   (workspace) DOUBLE PRECISION array, dimension at least */
-/*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */
-/*         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */
-
-/*  IWORK  (workspace) INTEGER array, dimension at least */
-/*         (3*N*NLVL + 11*N) */
-
-/*  INFO   (output) INTEGER */
-/*         = 0:  successful exit. */
-/*         < 0:  if INFO = -i, the i-th argument had an illegal value. */
-/*         > 0:  The algorithm failed to compute an singular value while */
-/*               working on the submatrix lying in rows and columns */
-/*               INFO/(N+1) through MOD(INFO,N+1). */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Ming Gu and Ren-Cang Li, Computer Science Division, University of */
-/*       California at Berkeley, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Test the input parameters. */
-
-    /* Parameter adjustments */
-    --d__;
-    --e;
-    b_dim1 = *ldb;
-    b_offset = 1 + b_dim1;
-    b -= b_offset;
-    --work;
-    --iwork;
-
-    /* Function Body */
-    *info = 0;
-
-    if (*n < 0) {
-	*info = -3;
-    } else if (*nrhs < 1) {
-	*info = -4;
-    } else if (*ldb < 1 || *ldb < *n) {
-	*info = -8;
-    }
-    if (*info != 0) {
-	i__1 = -(*info);
-	xerbla_("DLALSD", &i__1);
-	return 0;
-    }
-
-    eps = dlamch_("Epsilon");
-
-/*     Set up the tolerance. */
-
-    if (*rcond <= 0. || *rcond >= 1.) {
-	rcnd = eps;
-    } else {
-	rcnd = *rcond;
-    }
-
-    *rank = 0;
-
-/*     Quick return if possible. */
-
-    if (*n == 0) {
-	return 0;
-    } else if (*n == 1) {
-	if (d__[1] == 0.) {
-	    dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
-	} else {
-	    *rank = 1;
-	    dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
-		    b_offset], ldb, info);
-	    d__[1] = abs(d__[1]);
-	}
-	return 0;
-    }
-
-/*     Rotate the matrix if it is lower bidiagonal. */
-
-    if (*(unsigned char *)uplo == 'L') {
-	i__1 = *n - 1;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
-	    d__[i__] = r__;
-	    e[i__] = sn * d__[i__ + 1];
-	    d__[i__ + 1] = cs * d__[i__ + 1];
-	    if (*nrhs == 1) {
-		drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
-			c__1, &cs, &sn);
-	    } else {
-		work[(i__ << 1) - 1] = cs;
-		work[i__ * 2] = sn;
-	    }
-/* L10: */
-	}
-	if (*nrhs > 1) {
-	    i__1 = *nrhs;
-	    for (i__ = 1; i__ <= i__1; ++i__) {
-		i__2 = *n - 1;
-		for (j = 1; j <= i__2; ++j) {
-		    cs = work[(j << 1) - 1];
-		    sn = work[j * 2];
-		    drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ *
-			     b_dim1], &c__1, &cs, &sn);
-/* L20: */
-		}
-/* L30: */
-	    }
-	}
-    }
-
-/*     Scale. */
-
-    nm1 = *n - 1;
-    orgnrm = dlanst_("M", n, &d__[1], &e[1]);
-    if (orgnrm == 0.) {
-	dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
-	return 0;
-    }
-
-    dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
-    dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, 
-	    info);
-
-/*     If N is smaller than the minimum divide size SMLSIZ, then solve */
-/*     the problem with another solver. */
-
-    if (*n <= *smlsiz) {
-	nwork = *n * *n + 1;
-	dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
-	dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
-		work[1], n, &b[b_offset], ldb, &work[nwork], info);
-	if (*info != 0) {
-	    return 0;
-	}
-	tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
-	i__1 = *n;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    if (d__[i__] <= tol) {
-		dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb);
-	    } else {
-		dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[
-			i__ + b_dim1], ldb, info);
-		++(*rank);
-	    }
-/* L40: */
-	}
-	dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
-		c_b6, &work[nwork], n);
-	dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
-
-/*        Unscale. */
-
-	dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, 
-		info);
-	dlasrt_("D", n, &d__[1], info);
-	dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], 
-		ldb, info);
-
-	return 0;
-    }
-
-/*     Book-keeping and setting up some constants. */
-
-    nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) / 
-	    log(2.)) + 1;
-
-    smlszp = *smlsiz + 1;
-
-    u = 1;
-    vt = *smlsiz * *n + 1;
-    difl = vt + smlszp * *n;
-    difr = difl + nlvl * *n;
-    z__ = difr + (nlvl * *n << 1);
-    c__ = z__ + nlvl * *n;
-    s = c__ + *n;
-    poles = s + *n;
-    givnum = poles + (nlvl << 1) * *n;
-    bx = givnum + (nlvl << 1) * *n;
-    nwork = bx + *n * *nrhs;
-
-    sizei = *n + 1;
-    k = sizei + *n;
-    givptr = k + *n;
-    perm = givptr + *n;
-    givcol = perm + nlvl * *n;
-    iwk = givcol + (nlvl * *n << 1);
-
-    st = 1;
-    sqre = 0;
-    icmpq1 = 1;
-    icmpq2 = 0;
-    nsub = 0;
-
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	if ((d__1 = d__[i__], abs(d__1)) < eps) {
-	    d__[i__] = d_sign(&eps, &d__[i__]);
-	}
-/* L50: */
-    }
-
-    i__1 = nm1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
-	    ++nsub;
-	    iwork[nsub] = st;
-
-/*           Subproblem found. First determine its size and then */
-/*           apply divide and conquer on it. */
-
-	    if (i__ < nm1) {
-
-/*              A subproblem with E(I) small for I < NM1. */
-
-		nsize = i__ - st + 1;
-		iwork[sizei + nsub - 1] = nsize;
-	    } else if ((d__1 = e[i__], abs(d__1)) >= eps) {
-
-/*              A subproblem with E(NM1) not too small but I = NM1. */
-
-		nsize = *n - st + 1;
-		iwork[sizei + nsub - 1] = nsize;
-	    } else {
-
-/*              A subproblem with E(NM1) small. This implies an */
-/*              1-by-1 subproblem at D(N), which is not solved */
-/*              explicitly. */
-
-		nsize = i__ - st + 1;
-		iwork[sizei + nsub - 1] = nsize;
-		++nsub;
-		iwork[nsub] = *n;
-		iwork[sizei + nsub - 1] = 1;
-		dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
-	    }
-	    st1 = st - 1;
-	    if (nsize == 1) {
-
-/*              This is a 1-by-1 subproblem and is not solved */
-/*              explicitly. */
-
-		dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
-	    } else if (nsize <= *smlsiz) {
-
-/*              This is a small subproblem and is solved by DLASDQ. */
-
-		dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], 
-			n);
-		dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
-			st], &work[vt + st1], n, &work[nwork], n, &b[st + 
-			b_dim1], ldb, &work[nwork], info);
-		if (*info != 0) {
-		    return 0;
-		}
-		dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + 
-			st1], n);
-	    } else {
-
-/*              A large problem. Solve it using divide and conquer. */
-
-		dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
-			work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
-			work[difl + st1], &work[difr + st1], &work[z__ + st1], 
-			 &work[poles + st1], &iwork[givptr + st1], &iwork[
-			givcol + st1], n, &iwork[perm + st1], &work[givnum + 
-			st1], &work[c__ + st1], &work[s + st1], &work[nwork], 
-			&iwork[iwk], info);
-		if (*info != 0) {
-		    return 0;
-		}
-		bxst = bx + st1;
-		dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
-			work[bxst], n, &work[u + st1], n, &work[vt + st1], &
-			iwork[k + st1], &work[difl + st1], &work[difr + st1], 
-			&work[z__ + st1], &work[poles + st1], &iwork[givptr + 
-			st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
-			work[givnum + st1], &work[c__ + st1], &work[s + st1], 
-			&work[nwork], &iwork[iwk], info);
-		if (*info != 0) {
-		    return 0;
-		}
-	    }
-	    st = i__ + 1;
-	}
-/* L60: */
-    }
-
-/*     Apply the singular values and treat the tiny ones as zero. */
-
-    tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
-
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-
-/*        Some of the elements in D can be negative because 1-by-1 */
-/*        subproblems were not solved explicitly. */
-
-	if ((d__1 = d__[i__], abs(d__1)) <= tol) {
-	    dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
-	} else {
-	    ++(*rank);
-	    dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
-		    bx + i__ - 1], n, info);
-	}
-	d__[i__] = (d__1 = d__[i__], abs(d__1));
-/* L70: */
-    }
-
-/*     Now apply back the right singular vectors. */
-
-    icmpq2 = 1;
-    i__1 = nsub;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	st = iwork[i__];
-	st1 = st - 1;
-	nsize = iwork[sizei + i__ - 1];
-	bxst = bx + st1;
-	if (nsize == 1) {
-	    dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
-	} else if (nsize <= *smlsiz) {
-	    dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, 
-		     &work[bxst], n, &c_b6, &b[st + b_dim1], ldb);
-	} else {
-	    dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + 
-		    b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[
-		    k + st1], &work[difl + st1], &work[difr + st1], &work[z__ 
-		    + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
-		    givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], 
-		     &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
-		    iwk], info);
-	    if (*info != 0) {
-		return 0;
-	    }
-	}
-/* L80: */
-    }
-
-/*     Unscale and sort the singular values. */
-
-    dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
-    dlasrt_("D", n, &d__[1], info);
-    dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, 
-	    info);
-
-    return 0;
-
-/*     End of DLALSD */
-
-} /* dlalsd_ */

3rdparty/lapack/dlamch_custom.c

@@ -1,58 +0,0 @@
-#include "clapack.h"
-#include <float.h>
-#include <stdio.h>
-
-/* *********************************************************************** */
-
-doublereal dlamc3_(doublereal *a, doublereal *b)
-{
-    /* System generated locals */
-    doublereal ret_val;
-    
-    
-    /*  -- LAPACK auxiliary routine (version 3.1) -- */
-    /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-    /*     November 2006 */
-    
-    /*     .. Scalar Arguments .. */
-    /*     .. */
-    
-    /*  Purpose */
-    /*  ======= */
-    
-    /*  DLAMC3  is intended to force  A  and  B  to be stored prior to doing */
-    /*  the addition of  A  and  B ,  for use in situations where optimizers */
-    /*  might hold one of these in a register. */
-    
-    /*  Arguments */
-    /*  ========= */
-    
-    /*  A       (input) DOUBLE PRECISION */
-    /*  B       (input) DOUBLE PRECISION */
-    /*          The values A and B. */
-    
-    /* ===================================================================== */
-    
-    /*     .. Executable Statements .. */
-    
-    ret_val = *a + *b;
-    
-    return ret_val;
-    
-    /*     End of DLAMC3 */
-    
-} /* dlamc3_ */
-
-
-/* simpler version of dlamch for the case of IEEE754-compliant FPU module by Piotr Luszczek S.
-   taken from http://www.mail-archive.com/numpy-discussion@lists.sourceforge.net/msg02448.html */
-
-#ifndef DBL_DIGITS
-#define DBL_DIGITS 53
-#endif
-
-const doublereal lapack_dlamch_tab[] =
-{
-    0, FLT_RADIX, DBL_EPSILON, DBL_MAX_EXP, DBL_MIN_EXP, DBL_DIGITS, DBL_MAX,
-    DBL_EPSILON*FLT_RADIX, 1, DBL_MIN*(1 + DBL_EPSILON), DBL_MIN
-};

3rdparty/lapack/dlamrg.c

@@ -1,131 +0,0 @@
-/* dlamrg.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer 
-	*dtrd1, integer *dtrd2, integer *index)
-{
-    /* System generated locals */
-    integer i__1;
-
-    /* Local variables */
-    integer i__, ind1, ind2, n1sv, n2sv;
-
-
-/*  -- LAPACK routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAMRG will create a permutation list which will merge the elements */
-/*  of A (which is composed of two independently sorted sets) into a */
-/*  single set which is sorted in ascending order. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N1     (input) INTEGER */
-/*  N2     (input) INTEGER */
-/*         These arguements contain the respective lengths of the two */
-/*         sorted lists to be merged. */
-
-/*  A      (input) DOUBLE PRECISION array, dimension (N1+N2) */
-/*         The first N1 elements of A contain a list of numbers which */
-/*         are sorted in either ascending or descending order.  Likewise */
-/*         for the final N2 elements. */
-
-/*  DTRD1  (input) INTEGER */
-/*  DTRD2  (input) INTEGER */
-/*         These are the strides to be taken through the array A. */
-/*         Allowable strides are 1 and -1.  They indicate whether a */
-/*         subset of A is sorted in ascending (DTRDx = 1) or descending */
-/*         (DTRDx = -1) order. */
-
-/*  INDEX  (output) INTEGER array, dimension (N1+N2) */
-/*         On exit this array will contain a permutation such that */
-/*         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be */
-/*         sorted in ascending order. */
-
-/*  ===================================================================== */
-
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --index;
-    --a;
-
-    /* Function Body */
-    n1sv = *n1;
-    n2sv = *n2;
-    if (*dtrd1 > 0) {
-	ind1 = 1;
-    } else {
-	ind1 = *n1;
-    }
-    if (*dtrd2 > 0) {
-	ind2 = *n1 + 1;
-    } else {
-	ind2 = *n1 + *n2;
-    }
-    i__ = 1;
-/*     while ( (N1SV > 0) & (N2SV > 0) ) */
-L10:
-    if (n1sv > 0 && n2sv > 0) {
-	if (a[ind1] <= a[ind2]) {
-	    index[i__] = ind1;
-	    ++i__;
-	    ind1 += *dtrd1;
-	    --n1sv;
-	} else {
-	    index[i__] = ind2;
-	    ++i__;
-	    ind2 += *dtrd2;
-	    --n2sv;
-	}
-	goto L10;
-    }
-/*     end while */
-    if (n1sv == 0) {
-	i__1 = n2sv;
-	for (n1sv = 1; n1sv <= i__1; ++n1sv) {
-	    index[i__] = ind2;
-	    ++i__;
-	    ind2 += *dtrd2;
-/* L20: */
-	}
-    } else {
-/*     N2SV .EQ. 0 */
-	i__1 = n1sv;
-	for (n2sv = 1; n2sv <= i__1; ++n2sv) {
-	    index[i__] = ind1;
-	    ++i__;
-	    ind1 += *dtrd1;
-/* L30: */
-	}
-    }
-
-    return 0;
-
-/*     End of DLAMRG */
-
-} /* dlamrg_ */

3rdparty/lapack/dlaneg.c

@@ -1,218 +0,0 @@
-/* dlaneg.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-integer dlaneg_(integer *n, doublereal *d__, doublereal *lld, doublereal *
-	sigma, doublereal *pivmin, integer *r__)
-{
-    /* System generated locals */
-    integer ret_val, i__1, i__2, i__3, i__4;
-
-    /* Local variables */
-    integer j;
-    doublereal p, t;
-    integer bj;
-    doublereal tmp;
-    integer neg1, neg2;
-    doublereal bsav, gamma, dplus;
-    extern logical disnan_(doublereal *);
-    integer negcnt;
-    logical sawnan;
-    doublereal dminus;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLANEG computes the Sturm count, the number of negative pivots */
-/*  encountered while factoring tridiagonal T - sigma I = L D L^T. */
-/*  This implementation works directly on the factors without forming */
-/*  the tridiagonal matrix T.  The Sturm count is also the number of */
-/*  eigenvalues of T less than sigma. */
-
-/*  This routine is called from DLARRB. */
-
-/*  The current routine does not use the PIVMIN parameter but rather */
-/*  requires IEEE-754 propagation of Infinities and NaNs.  This */
-/*  routine also has no input range restrictions but does require */
-/*  default exception handling such that x/0 produces Inf when x is */
-/*  non-zero, and Inf/Inf produces NaN.  For more information, see: */
-
-/*    Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in */
-/*    Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on */
-/*    Scientific Computing, v28, n5, 2006.  DOI 10.1137/050641624 */
-/*    (Tech report version in LAWN 172 with the same title.) */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The N diagonal elements of the diagonal matrix D. */
-
-/*  LLD     (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The (N-1) elements L(i)*L(i)*D(i). */
-
-/*  SIGMA   (input) DOUBLE PRECISION */
-/*          Shift amount in T - sigma I = L D L^T. */
-
-/*  PIVMIN  (input) DOUBLE PRECISION */
-/*          The minimum pivot in the Sturm sequence.  May be used */
-/*          when zero pivots are encountered on non-IEEE-754 */
-/*          architectures. */
-
-/*  R       (input) INTEGER */
-/*          The twist index for the twisted factorization that is used */
-/*          for the negcount. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-/*     Jason Riedy, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     Some architectures propagate Infinities and NaNs very slowly, so */
-/*     the code computes counts in BLKLEN chunks.  Then a NaN can */
-/*     propagate at most BLKLEN columns before being detected.  This is */
-/*     not a general tuning parameter; it needs only to be just large */
-/*     enough that the overhead is tiny in common cases. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-    /* Parameter adjustments */
-    --lld;
-    --d__;
-
-    /* Function Body */
-    negcnt = 0;
-/*     I) upper part: L D L^T - SIGMA I = L+ D+ L+^T */
-    t = -(*sigma);
-    i__1 = *r__ - 1;
-    for (bj = 1; bj <= i__1; bj += 128) {
-	neg1 = 0;
-	bsav = t;
-/* Computing MIN */
-	i__3 = bj + 127, i__4 = *r__ - 1;
-	i__2 = min(i__3,i__4);
-	for (j = bj; j <= i__2; ++j) {
-	    dplus = d__[j] + t;
-	    if (dplus < 0.) {
-		++neg1;
-	    }
-	    tmp = t / dplus;
-	    t = tmp * lld[j] - *sigma;
-/* L21: */
-	}
-	sawnan = disnan_(&t);
-/*     Run a slower version of the above loop if a NaN is detected. */
-/*     A NaN should occur only with a zero pivot after an infinite */
-/*     pivot.  In that case, substituting 1 for T/DPLUS is the */
-/*     correct limit. */
-	if (sawnan) {
-	    neg1 = 0;
-	    t = bsav;
-/* Computing MIN */
-	    i__3 = bj + 127, i__4 = *r__ - 1;
-	    i__2 = min(i__3,i__4);
-	    for (j = bj; j <= i__2; ++j) {
-		dplus = d__[j] + t;
-		if (dplus < 0.) {
-		    ++neg1;
-		}
-		tmp = t / dplus;
-		if (disnan_(&tmp)) {
-		    tmp = 1.;
-		}
-		t = tmp * lld[j] - *sigma;
-/* L22: */
-	    }
-	}
-	negcnt += neg1;
-/* L210: */
-    }
-
-/*     II) lower part: L D L^T - SIGMA I = U- D- U-^T */
-    p = d__[*n] - *sigma;
-    i__1 = *r__;
-    for (bj = *n - 1; bj >= i__1; bj += -128) {
-	neg2 = 0;
-	bsav = p;
-/* Computing MAX */
-	i__3 = bj - 127;
-	i__2 = max(i__3,*r__);
-	for (j = bj; j >= i__2; --j) {
-	    dminus = lld[j] + p;
-	    if (dminus < 0.) {
-		++neg2;
-	    }
-	    tmp = p / dminus;
-	    p = tmp * d__[j] - *sigma;
-/* L23: */
-	}
-	sawnan = disnan_(&p);
-/*     As above, run a slower version that substitutes 1 for Inf/Inf. */
-
-	if (sawnan) {
-	    neg2 = 0;
-	    p = bsav;
-/* Computing MAX */
-	    i__3 = bj - 127;
-	    i__2 = max(i__3,*r__);
-	    for (j = bj; j >= i__2; --j) {
-		dminus = lld[j] + p;
-		if (dminus < 0.) {
-		    ++neg2;
-		}
-		tmp = p / dminus;
-		if (disnan_(&tmp)) {
-		    tmp = 1.;
-		}
-		p = tmp * d__[j] - *sigma;
-/* L24: */
-	    }
-	}
-	negcnt += neg2;
-/* L230: */
-    }
-
-/*     III) Twist index */
-/*       T was shifted by SIGMA initially. */
-    gamma = t + *sigma + p;
-    if (gamma < 0.) {
-	++negcnt;
-    }
-    ret_val = negcnt;
-    return ret_val;
-} /* dlaneg_ */

3rdparty/lapack/dlange.c

@@ -1,199 +0,0 @@
-/* dlange.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-
-doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer 
-	*lda, doublereal *work)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2;
-    doublereal ret_val, d__1, d__2, d__3;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    integer i__, j;
-    doublereal sum, scale;
-    extern logical lsame_(char *, char *);
-    doublereal value;
-    extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, 
-	    doublereal *, doublereal *);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLANGE  returns the value of the one norm,  or the Frobenius norm, or */
-/*  the  infinity norm,  or the  element of  largest absolute value  of a */
-/*  real matrix A. */
-
-/*  Description */
-/*  =========== */
-
-/*  DLANGE returns the value */
-
-/*     DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
-/*              ( */
-/*              ( norm1(A),         NORM = '1', 'O' or 'o' */
-/*              ( */
-/*              ( normI(A),         NORM = 'I' or 'i' */
-/*              ( */
-/*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e' */
-
-/*  where  norm1  denotes the  one norm of a matrix (maximum column sum), */
-/*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and */
-/*  normF  denotes the  Frobenius norm of a matrix (square root of sum of */
-/*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  NORM    (input) CHARACTER*1 */
-/*          Specifies the value to be returned in DLANGE as described */
-/*          above. */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix A.  M >= 0.  When M = 0, */
-/*          DLANGE is set to zero. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix A.  N >= 0.  When N = 0, */
-/*          DLANGE is set to zero. */
-
-/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          The m by n matrix A. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(M,1). */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
-/*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
-/*          referenced. */
-
-/* ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --work;
-
-    /* Function Body */
-    if (min(*m,*n) == 0) {
-	value = 0.;
-    } else if (lsame_(norm, "M")) {
-
-/*        Find max(abs(A(i,j))). */
-
-	value = 0.;
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    i__2 = *m;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-/* Computing MAX */
-		d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
-		value = max(d__2,d__3);
-/* L10: */
-	    }
-/* L20: */
-	}
-    } else if (lsame_(norm, "O") || *(unsigned char *)
-	    norm == '1') {
-
-/*        Find norm1(A). */
-
-	value = 0.;
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    sum = 0.;
-	    i__2 = *m;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
-/* L30: */
-	    }
-	    value = max(value,sum);
-/* L40: */
-	}
-    } else if (lsame_(norm, "I")) {
-
-/*        Find normI(A). */
-
-	i__1 = *m;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    work[i__] = 0.;
-/* L50: */
-	}
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    i__2 = *m;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
-/* L60: */
-	    }
-/* L70: */
-	}
-	value = 0.;
-	i__1 = *m;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-/* Computing MAX */
-	    d__1 = value, d__2 = work[i__];
-	    value = max(d__1,d__2);
-/* L80: */
-	}
-    } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
-
-/*        Find normF(A). */
-
-	scale = 0.;
-	sum = 1.;
-	i__1 = *n;
-	for (j = 1; j <= i__1; ++j) {
-	    dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
-/* L90: */
-	}
-	value = scale * sqrt(sum);
-    }
-
-    ret_val = value;
-    return ret_val;
-
-/*     End of DLANGE */
-
-} /* dlange_ */

3rdparty/lapack/dlanst.c

@@ -1,166 +0,0 @@
-/* dlanst.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-
-doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal ret_val, d__1, d__2, d__3, d__4, d__5;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    integer i__;
-    doublereal sum, scale;
-    extern logical lsame_(char *, char *);
-    doublereal anorm;
-    extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, 
-	    doublereal *, doublereal *);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLANST  returns the value of the one norm,  or the Frobenius norm, or */
-/*  the  infinity norm,  or the  element of  largest absolute value  of a */
-/*  real symmetric tridiagonal matrix A. */
-
-/*  Description */
-/*  =========== */
-
-/*  DLANST returns the value */
-
-/*     DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
-/*              ( */
-/*              ( norm1(A),         NORM = '1', 'O' or 'o' */
-/*              ( */
-/*              ( normI(A),         NORM = 'I' or 'i' */
-/*              ( */
-/*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e' */
-
-/*  where  norm1  denotes the  one norm of a matrix (maximum column sum), */
-/*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and */
-/*  normF  denotes the  Frobenius norm of a matrix (square root of sum of */
-/*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  NORM    (input) CHARACTER*1 */
-/*          Specifies the value to be returned in DLANST as described */
-/*          above. */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix A.  N >= 0.  When N = 0, DLANST is */
-/*          set to zero. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The diagonal elements of A. */
-
-/*  E       (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The (n-1) sub-diagonal or super-diagonal elements of A. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --e;
-    --d__;
-
-    /* Function Body */
-    if (*n <= 0) {
-	anorm = 0.;
-    } else if (lsame_(norm, "M")) {
-
-/*        Find max(abs(A(i,j))). */
-
-	anorm = (d__1 = d__[*n], abs(d__1));
-	i__1 = *n - 1;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-/* Computing MAX */
-	    d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1));
-	    anorm = max(d__2,d__3);
-/* Computing MAX */
-	    d__2 = anorm, d__3 = (d__1 = e[i__], abs(d__1));
-	    anorm = max(d__2,d__3);
-/* L10: */
-	}
-    } else if (lsame_(norm, "O") || *(unsigned char *)
-	    norm == '1' || lsame_(norm, "I")) {
-
-/*        Find norm1(A). */
-
-	if (*n == 1) {
-	    anorm = abs(d__[1]);
-	} else {
-/* Computing MAX */
-	    d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = e[*n - 1], abs(
-		    d__1)) + (d__2 = d__[*n], abs(d__2));
-	    anorm = max(d__3,d__4);
-	    i__1 = *n - 1;
-	    for (i__ = 2; i__ <= i__1; ++i__) {
-/* Computing MAX */
-		d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[
-			i__], abs(d__2)) + (d__3 = e[i__ - 1], abs(d__3));
-		anorm = max(d__4,d__5);
-/* L20: */
-	    }
-	}
-    } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
-
-/*        Find normF(A). */
-
-	scale = 0.;
-	sum = 1.;
-	if (*n > 1) {
-	    i__1 = *n - 1;
-	    dlassq_(&i__1, &e[1], &c__1, &scale, &sum);
-	    sum *= 2;
-	}
-	dlassq_(n, &d__[1], &c__1, &scale, &sum);
-	anorm = scale * sqrt(sum);
-    }
-
-    ret_val = anorm;
-    return ret_val;
-
-/*     End of DLANST */
-
-} /* dlanst_ */

3rdparty/lapack/dlansy.c

@@ -1,239 +0,0 @@
-/* dlansy.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-
-doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer 
-	*lda, doublereal *work)
-{
-    /* System generated locals */
-    integer a_dim1, a_offset, i__1, i__2;
-    doublereal ret_val, d__1, d__2, d__3;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    integer i__, j;
-    doublereal sum, absa, scale;
-    extern logical lsame_(char *, char *);
-    doublereal value;
-    extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, 
-	    doublereal *, doublereal *);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLANSY  returns the value of the one norm,  or the Frobenius norm, or */
-/*  the  infinity norm,  or the  element of  largest absolute value  of a */
-/*  real symmetric matrix A. */
-
-/*  Description */
-/*  =========== */
-
-/*  DLANSY returns the value */
-
-/*     DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
-/*              ( */
-/*              ( norm1(A),         NORM = '1', 'O' or 'o' */
-/*              ( */
-/*              ( normI(A),         NORM = 'I' or 'i' */
-/*              ( */
-/*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e' */
-
-/*  where  norm1  denotes the  one norm of a matrix (maximum column sum), */
-/*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and */
-/*  normF  denotes the  Frobenius norm of a matrix (square root of sum of */
-/*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  NORM    (input) CHARACTER*1 */
-/*          Specifies the value to be returned in DLANSY as described */
-/*          above. */
-
-/*  UPLO    (input) CHARACTER*1 */
-/*          Specifies whether the upper or lower triangular part of the */
-/*          symmetric matrix A is to be referenced. */
-/*          = 'U':  Upper triangular part of A is referenced */
-/*          = 'L':  Lower triangular part of A is referenced */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix A.  N >= 0.  When N = 0, DLANSY is */
-/*          set to zero. */
-
-/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
-/*          The symmetric matrix A.  If UPLO = 'U', the leading n by n */
-/*          upper triangular part of A contains the upper triangular part */
-/*          of the matrix A, and the strictly lower triangular part of A */
-/*          is not referenced.  If UPLO = 'L', the leading n by n lower */
-/*          triangular part of A contains the lower triangular part of */
-/*          the matrix A, and the strictly upper triangular part of A is */
-/*          not referenced. */
-
-/*  LDA     (input) INTEGER */
-/*          The leading dimension of the array A.  LDA >= max(N,1). */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
-/*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
-/*          WORK is not referenced. */
-
-/* ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    a_dim1 = *lda;
-    a_offset = 1 + a_dim1;
-    a -= a_offset;
-    --work;
-
-    /* Function Body */
-    if (*n == 0) {
-	value = 0.;
-    } else if (lsame_(norm, "M")) {
-
-/*        Find max(abs(A(i,j))). */
-
-	value = 0.;
-	if (lsame_(uplo, "U")) {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = j;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-/* Computing MAX */
-		    d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
-			    d__1));
-		    value = max(d__2,d__3);
-/* L10: */
-		}
-/* L20: */
-	    }
-	} else {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = *n;
-		for (i__ = j; i__ <= i__2; ++i__) {
-/* Computing MAX */
-		    d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
-			    d__1));
-		    value = max(d__2,d__3);
-/* L30: */
-		}
-/* L40: */
-	    }
-	}
-    } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
-
-/*        Find normI(A) ( = norm1(A), since A is symmetric). */
-
-	value = 0.;
-	if (lsame_(uplo, "U")) {
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		sum = 0.;
-		i__2 = j - 1;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    absa = (d__1 = a[i__ + j * a_dim1], abs(d__1));
-		    sum += absa;
-		    work[i__] += absa;
-/* L50: */
-		}
-		work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1));
-/* L60: */
-	    }
-	    i__1 = *n;
-	    for (i__ = 1; i__ <= i__1; ++i__) {
-/* Computing MAX */
-		d__1 = value, d__2 = work[i__];
-		value = max(d__1,d__2);
-/* L70: */
-	    }
-	} else {
-	    i__1 = *n;
-	    for (i__ = 1; i__ <= i__1; ++i__) {
-		work[i__] = 0.;
-/* L80: */
-	    }
-	    i__1 = *n;
-	    for (j = 1; j <= i__1; ++j) {
-		sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1));
-		i__2 = *n;
-		for (i__ = j + 1; i__ <= i__2; ++i__) {
-		    absa = (d__1 = a[i__ + j * a_dim1], abs(d__1));
-		    sum += absa;
-		    work[i__] += absa;
-/* L90: */
-		}
-		value = max(value,sum);
-/* L100: */
-	    }
-	}
-    } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
-
-/*        Find normF(A). */
-
-	scale = 0.;
-	sum = 1.;
-	if (lsame_(uplo, "U")) {
-	    i__1 = *n;
-	    for (j = 2; j <= i__1; ++j) {
-		i__2 = j - 1;
-		dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
-/* L110: */
-	    }
-	} else {
-	    i__1 = *n - 1;
-	    for (j = 1; j <= i__1; ++j) {
-		i__2 = *n - j;
-		dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
-/* L120: */
-	    }
-	}
-	sum *= 2;
-	i__1 = *lda + 1;
-	dlassq_(n, &a[a_offset], &i__1, &scale, &sum);
-	value = scale * sqrt(sum);
-    }
-
-    ret_val = value;
-    return ret_val;
-
-/*     End of DLANSY */
-
-} /* dlansy_ */

3rdparty/lapack/dlapy2.c

@@ -1,73 +0,0 @@
-/* dlapy2.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-doublereal dlapy2_(doublereal *x, doublereal *y)
-{
-    /* System generated locals */
-    doublereal ret_val, d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    doublereal w, z__, xabs, yabs;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary */
-/*  overflow. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  X       (input) DOUBLE PRECISION */
-/*  Y       (input) DOUBLE PRECISION */
-/*          X and Y specify the values x and y. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    xabs = abs(*x);
-    yabs = abs(*y);
-    w = max(xabs,yabs);
-    z__ = min(xabs,yabs);
-    if (z__ == 0.) {
-	ret_val = w;
-    } else {
-/* Computing 2nd power */
-	d__1 = z__ / w;
-	ret_val = w * sqrt(d__1 * d__1 + 1.);
-    }
-    return ret_val;
-
-/*     End of DLAPY2 */
-
-} /* dlapy2_ */

3rdparty/lapack/dlar1v.c

@@ -1,441 +0,0 @@
-/* dlar1v.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlar1v_(integer *n, integer *b1, integer *bn, doublereal 
-	*lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal *
-	lld, doublereal *pivmin, doublereal *gaptol, doublereal *z__, logical 
-	*wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma, 
-	integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid, 
-	doublereal *rqcorr, doublereal *work)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1, d__2, d__3;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    integer i__;
-    doublereal s;
-    integer r1, r2;
-    doublereal eps, tmp;
-    integer neg1, neg2, indp, inds;
-    doublereal dplus;
-    extern doublereal dlamch_(char *);
-    extern logical disnan_(doublereal *);
-    integer indlpl, indumn;
-    doublereal dminus;
-    logical sawnan1, sawnan2;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLAR1V computes the (scaled) r-th column of the inverse of */
-/*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix */
-/*  L D L^T - sigma I. When sigma is close to an eigenvalue, the */
-/*  computed vector is an accurate eigenvector. Usually, r corresponds */
-/*  to the index where the eigenvector is largest in magnitude. */
-/*  The following steps accomplish this computation : */
-/*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T, */
-/*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, */
-/*  (c) Computation of the diagonal elements of the inverse of */
-/*      L D L^T - sigma I by combining the above transforms, and choosing */
-/*      r as the index where the diagonal of the inverse is (one of the) */
-/*      largest in magnitude. */
-/*  (d) Computation of the (scaled) r-th column of the inverse using the */
-/*      twisted factorization obtained by combining the top part of the */
-/*      the stationary and the bottom part of the progressive transform. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N        (input) INTEGER */
-/*           The order of the matrix L D L^T. */
-
-/*  B1       (input) INTEGER */
-/*           First index of the submatrix of L D L^T. */
-
-/*  BN       (input) INTEGER */
-/*           Last index of the submatrix of L D L^T. */
-
-/*  LAMBDA    (input) DOUBLE PRECISION */
-/*           The shift. In order to compute an accurate eigenvector, */
-/*           LAMBDA should be a good approximation to an eigenvalue */
-/*           of L D L^T. */
-
-/*  L        (input) DOUBLE PRECISION array, dimension (N-1) */
-/*           The (n-1) subdiagonal elements of the unit bidiagonal matrix */
-/*           L, in elements 1 to N-1. */
-
-/*  D        (input) DOUBLE PRECISION array, dimension (N) */
-/*           The n diagonal elements of the diagonal matrix D. */
-
-/*  LD       (input) DOUBLE PRECISION array, dimension (N-1) */
-/*           The n-1 elements L(i)*D(i). */
-
-/*  LLD      (input) DOUBLE PRECISION array, dimension (N-1) */
-/*           The n-1 elements L(i)*L(i)*D(i). */
-
-/*  PIVMIN   (input) DOUBLE PRECISION */
-/*           The minimum pivot in the Sturm sequence. */
-
-/*  GAPTOL   (input) DOUBLE PRECISION */
-/*           Tolerance that indicates when eigenvector entries are negligible */
-/*           w.r.t. their contribution to the residual. */
-
-/*  Z        (input/output) DOUBLE PRECISION array, dimension (N) */
-/*           On input, all entries of Z must be set to 0. */
-/*           On output, Z contains the (scaled) r-th column of the */
-/*           inverse. The scaling is such that Z(R) equals 1. */
-
-/*  WANTNC   (input) LOGICAL */
-/*           Specifies whether NEGCNT has to be computed. */
-
-/*  NEGCNT   (output) INTEGER */
-/*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */
-/*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise. */
-
-/*  ZTZ      (output) DOUBLE PRECISION */
-/*           The square of the 2-norm of Z. */
-
-/*  MINGMA   (output) DOUBLE PRECISION */
-/*           The reciprocal of the largest (in magnitude) diagonal */
-/*           element of the inverse of L D L^T - sigma I. */
-
-/*  R        (input/output) INTEGER */
-/*           The twist index for the twisted factorization used to */
-/*           compute Z. */
-/*           On input, 0 <= R <= N. If R is input as 0, R is set to */
-/*           the index where (L D L^T - sigma I)^{-1} is largest */
-/*           in magnitude. If 1 <= R <= N, R is unchanged. */
-/*           On output, R contains the twist index used to compute Z. */
-/*           Ideally, R designates the position of the maximum entry in the */
-/*           eigenvector. */
-
-/*  ISUPPZ   (output) INTEGER array, dimension (2) */
-/*           The support of the vector in Z, i.e., the vector Z is */
-/*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */
-
-/*  NRMINV   (output) DOUBLE PRECISION */
-/*           NRMINV = 1/SQRT( ZTZ ) */
-
-/*  RESID    (output) DOUBLE PRECISION */
-/*           The residual of the FP vector. */
-/*           RESID = ABS( MINGMA )/SQRT( ZTZ ) */
-
-/*  RQCORR   (output) DOUBLE PRECISION */
-/*           The Rayleigh Quotient correction to LAMBDA. */
-/*           RQCORR = MINGMA*TMP */
-
-/*  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N) */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --work;
-    --isuppz;
-    --z__;
-    --lld;
-    --ld;
-    --l;
-    --d__;
-
-    /* Function Body */
-    eps = dlamch_("Precision");
-    if (*r__ == 0) {
-	r1 = *b1;
-	r2 = *bn;
-    } else {
-	r1 = *r__;
-	r2 = *r__;
-    }
-/*     Storage for LPLUS */
-    indlpl = 0;
-/*     Storage for UMINUS */
-    indumn = *n;
-    inds = (*n << 1) + 1;
-    indp = *n * 3 + 1;
-    if (*b1 == 1) {
-	work[inds] = 0.;
-    } else {
-	work[inds + *b1 - 1] = lld[*b1 - 1];
-    }
-
-/*     Compute the stationary transform (using the differential form) */
-/*     until the index R2. */
-
-    sawnan1 = FALSE_;
-    neg1 = 0;
-    s = work[inds + *b1 - 1] - *lambda;
-    i__1 = r1 - 1;
-    for (i__ = *b1; i__ <= i__1; ++i__) {
-	dplus = d__[i__] + s;
-	work[indlpl + i__] = ld[i__] / dplus;
-	if (dplus < 0.) {
-	    ++neg1;
-	}
-	work[inds + i__] = s * work[indlpl + i__] * l[i__];
-	s = work[inds + i__] - *lambda;
-/* L50: */
-    }
-    sawnan1 = disnan_(&s);
-    if (sawnan1) {
-	goto L60;
-    }
-    i__1 = r2 - 1;
-    for (i__ = r1; i__ <= i__1; ++i__) {
-	dplus = d__[i__] + s;
-	work[indlpl + i__] = ld[i__] / dplus;
-	work[inds + i__] = s * work[indlpl + i__] * l[i__];
-	s = work[inds + i__] - *lambda;
-/* L51: */
-    }
-    sawnan1 = disnan_(&s);
-
-L60:
-    if (sawnan1) {
-/*        Runs a slower version of the above loop if a NaN is detected */
-	neg1 = 0;
-	s = work[inds + *b1 - 1] - *lambda;
-	i__1 = r1 - 1;
-	for (i__ = *b1; i__ <= i__1; ++i__) {
-	    dplus = d__[i__] + s;
-	    if (abs(dplus) < *pivmin) {
-		dplus = -(*pivmin);
-	    }
-	    work[indlpl + i__] = ld[i__] / dplus;
-	    if (dplus < 0.) {
-		++neg1;
-	    }
-	    work[inds + i__] = s * work[indlpl + i__] * l[i__];
-	    if (work[indlpl + i__] == 0.) {
-		work[inds + i__] = lld[i__];
-	    }
-	    s = work[inds + i__] - *lambda;
-/* L70: */
-	}
-	i__1 = r2 - 1;
-	for (i__ = r1; i__ <= i__1; ++i__) {
-	    dplus = d__[i__] + s;
-	    if (abs(dplus) < *pivmin) {
-		dplus = -(*pivmin);
-	    }
-	    work[indlpl + i__] = ld[i__] / dplus;
-	    work[inds + i__] = s * work[indlpl + i__] * l[i__];
-	    if (work[indlpl + i__] == 0.) {
-		work[inds + i__] = lld[i__];
-	    }
-	    s = work[inds + i__] - *lambda;
-/* L71: */
-	}
-    }
-
-/*     Compute the progressive transform (using the differential form) */
-/*     until the index R1 */
-
-    sawnan2 = FALSE_;
-    neg2 = 0;
-    work[indp + *bn - 1] = d__[*bn] - *lambda;
-    i__1 = r1;
-    for (i__ = *bn - 1; i__ >= i__1; --i__) {
-	dminus = lld[i__] + work[indp + i__];
-	tmp = d__[i__] / dminus;
-	if (dminus < 0.) {
-	    ++neg2;
-	}
-	work[indumn + i__] = l[i__] * tmp;
-	work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
-/* L80: */
-    }
-    tmp = work[indp + r1 - 1];
-    sawnan2 = disnan_(&tmp);
-    if (sawnan2) {
-/*        Runs a slower version of the above loop if a NaN is detected */
-	neg2 = 0;
-	i__1 = r1;
-	for (i__ = *bn - 1; i__ >= i__1; --i__) {
-	    dminus = lld[i__] + work[indp + i__];
-	    if (abs(dminus) < *pivmin) {
-		dminus = -(*pivmin);
-	    }
-	    tmp = d__[i__] / dminus;
-	    if (dminus < 0.) {
-		++neg2;
-	    }
-	    work[indumn + i__] = l[i__] * tmp;
-	    work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
-	    if (tmp == 0.) {
-		work[indp + i__ - 1] = d__[i__] - *lambda;
-	    }
-/* L100: */
-	}
-    }
-
-/*     Find the index (from R1 to R2) of the largest (in magnitude) */
-/*     diagonal element of the inverse */
-
-    *mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
-    if (*mingma < 0.) {
-	++neg1;
-    }
-    if (*wantnc) {
-	*negcnt = neg1 + neg2;
-    } else {
-	*negcnt = -1;
-    }
-    if (abs(*mingma) == 0.) {
-	*mingma = eps * work[inds + r1 - 1];
-    }
-    *r__ = r1;
-    i__1 = r2 - 1;
-    for (i__ = r1; i__ <= i__1; ++i__) {
-	tmp = work[inds + i__] + work[indp + i__];
-	if (tmp == 0.) {
-	    tmp = eps * work[inds + i__];
-	}
-	if (abs(tmp) <= abs(*mingma)) {
-	    *mingma = tmp;
-	    *r__ = i__ + 1;
-	}
-/* L110: */
-    }
-
-/*     Compute the FP vector: solve N^T v = e_r */
-
-    isuppz[1] = *b1;
-    isuppz[2] = *bn;
-    z__[*r__] = 1.;
-    *ztz = 1.;
-
-/*     Compute the FP vector upwards from R */
-
-    if (! sawnan1 && ! sawnan2) {
-	i__1 = *b1;
-	for (i__ = *r__ - 1; i__ >= i__1; --i__) {
-	    z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
-	    if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
-		    d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
-		z__[i__] = 0.;
-		isuppz[1] = i__ + 1;
-		goto L220;
-	    }
-	    *ztz += z__[i__] * z__[i__];
-/* L210: */
-	}
-L220:
-	;
-    } else {
-/*        Run slower loop if NaN occurred. */
-	i__1 = *b1;
-	for (i__ = *r__ - 1; i__ >= i__1; --i__) {
-	    if (z__[i__ + 1] == 0.) {
-		z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2];
-	    } else {
-		z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
-	    }
-	    if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
-		    d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
-		z__[i__] = 0.;
-		isuppz[1] = i__ + 1;
-		goto L240;
-	    }
-	    *ztz += z__[i__] * z__[i__];
-/* L230: */
-	}
-L240:
-	;
-    }
-/*     Compute the FP vector downwards from R in blocks of size BLKSIZ */
-    if (! sawnan1 && ! sawnan2) {
-	i__1 = *bn - 1;
-	for (i__ = *r__; i__ <= i__1; ++i__) {
-	    z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
-	    if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
-		    d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
-		z__[i__ + 1] = 0.;
-		isuppz[2] = i__;
-		goto L260;
-	    }
-	    *ztz += z__[i__ + 1] * z__[i__ + 1];
-/* L250: */
-	}
-L260:
-	;
-    } else {
-/*        Run slower loop if NaN occurred. */
-	i__1 = *bn - 1;
-	for (i__ = *r__; i__ <= i__1; ++i__) {
-	    if (z__[i__] == 0.) {
-		z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1];
-	    } else {
-		z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
-	    }
-	    if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
-		    d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
-		z__[i__ + 1] = 0.;
-		isuppz[2] = i__;
-		goto L280;
-	    }
-	    *ztz += z__[i__ + 1] * z__[i__ + 1];
-/* L270: */
-	}
-L280:
-	;
-    }
-
-/*     Compute quantities for convergence test */
-
-    tmp = 1. / *ztz;
-    *nrminv = sqrt(tmp);
-    *resid = abs(*mingma) * *nrminv;
-    *rqcorr = *mingma * tmp;
-
-
-    return 0;
-
-/*     End of DLAR1V */
-
-} /* dlar1v_ */

3rdparty/lapack/dlarf.c

@@ -1,193 +0,0 @@
-/* dlarf.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static doublereal c_b4 = 1.;
-static doublereal c_b5 = 0.;
-static integer c__1 = 1;
-
-/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v, 
-	 integer *incv, doublereal *tau, doublereal *c__, integer *ldc, 
-	doublereal *work)
-{
-    /* System generated locals */
-    integer c_dim1, c_offset;
-    doublereal d__1;
-
-    /* Local variables */
-    integer i__;
-    logical applyleft;
-    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
-	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
-	    integer *);
-    extern logical lsame_(char *, char *);
-    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
-	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
-	    doublereal *, doublereal *, integer *);
-    integer lastc, lastv;
-    extern integer iladlc_(integer *, integer *, doublereal *, integer *), 
-	    iladlr_(integer *, integer *, doublereal *, integer *);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLARF applies a real elementary reflector H to a real m by n matrix */
-/*  C, from either the left or the right. H is represented in the form */
-
-/*        H = I - tau * v * v' */
-
-/*  where tau is a real scalar and v is a real vector. */
-
-/*  If tau = 0, then H is taken to be the unit matrix. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  SIDE    (input) CHARACTER*1 */
-/*          = 'L': form  H * C */
-/*          = 'R': form  C * H */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix C. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix C. */
-
-/*  V       (input) DOUBLE PRECISION array, dimension */
-/*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
-/*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
-/*          The vector v in the representation of H. V is not used if */
-/*          TAU = 0. */
-
-/*  INCV    (input) INTEGER */
-/*          The increment between elements of v. INCV <> 0. */
-
-/*  TAU     (input) DOUBLE PRECISION */
-/*          The value tau in the representation of H. */
-
-/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
-/*          On entry, the m by n matrix C. */
-/*          On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
-/*          or C * H if SIDE = 'R'. */
-
-/*  LDC     (input) INTEGER */
-/*          The leading dimension of the array C. LDC >= max(1,M). */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension */
-/*                         (N) if SIDE = 'L' */
-/*                      or (M) if SIDE = 'R' */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --v;
-    c_dim1 = *ldc;
-    c_offset = 1 + c_dim1;
-    c__ -= c_offset;
-    --work;
-
-    /* Function Body */
-    applyleft = lsame_(side, "L");
-    lastv = 0;
-    lastc = 0;
-    if (*tau != 0.) {
-/*     Set up variables for scanning V.  LASTV begins pointing to the end */
-/*     of V. */
-	if (applyleft) {
-	    lastv = *m;
-	} else {
-	    lastv = *n;
-	}
-	if (*incv > 0) {
-	    i__ = (lastv - 1) * *incv + 1;
-	} else {
-	    i__ = 1;
-	}
-/*     Look for the last non-zero row in V. */
-	while(lastv > 0 && v[i__] == 0.) {
-	    --lastv;
-	    i__ -= *incv;
-	}
-	if (applyleft) {
-/*     Scan for the last non-zero column in C(1:lastv,:). */
-	    lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
-	} else {
-/*     Scan for the last non-zero row in C(:,1:lastv). */
-	    lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
-	}
-    }
-/*     Note that lastc.eq.0 renders the BLAS operations null; no special */
-/*     case is needed at this level. */
-    if (applyleft) {
-
-/*        Form  H * C */
-
-	if (lastv > 0) {
-
-/*           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */
-
-	    dgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &
-		    v[1], incv, &c_b5, &work[1], &c__1);
-
-/*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */
-
-	    d__1 = -(*tau);
-	    dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[
-		    c_offset], ldc);
-	}
-    } else {
-
-/*        Form  C * H */
-
-	if (lastv > 0) {
-
-/*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
-
-	    dgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, 
-		     &v[1], incv, &c_b5, &work[1], &c__1);
-
-/*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */
-
-	    d__1 = -(*tau);
-	    dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[
-		    c_offset], ldc);
-	}
-    }
-    return 0;
-
-/*     End of DLARF */
-
-} /* dlarf_ */

3rdparty/lapack/dlarfb.c

@@ -1,774 +0,0 @@
-/* dlarfb.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static doublereal c_b14 = 1.;
-static doublereal c_b25 = -1.;
-
-/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char *
-	storev, integer *m, integer *n, integer *k, doublereal *v, integer *
-	ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, 
-	doublereal *work, integer *ldwork)
-{
-    /* System generated locals */
-    integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, 
-	    work_offset, i__1, i__2;
-
-    /* Local variables */
-    integer i__, j;
-    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
-	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
-	    integer *, doublereal *, doublereal *, integer *);
-    extern logical lsame_(char *, char *);
-    integer lastc;
-    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *), dtrmm_(char *, char *, char *, char *, 
-	    integer *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *, integer *);
-    integer lastv;
-    extern integer iladlc_(integer *, integer *, doublereal *, integer *), 
-	    iladlr_(integer *, integer *, doublereal *, integer *);
-    char transt[1];
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLARFB applies a real block reflector H or its transpose H' to a */
-/*  real m by n matrix C, from either the left or the right. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  SIDE    (input) CHARACTER*1 */
-/*          = 'L': apply H or H' from the Left */
-/*          = 'R': apply H or H' from the Right */
-
-/*  TRANS   (input) CHARACTER*1 */
-/*          = 'N': apply H (No transpose) */
-/*          = 'T': apply H' (Transpose) */
-
-/*  DIRECT  (input) CHARACTER*1 */
-/*          Indicates how H is formed from a product of elementary */
-/*          reflectors */
-/*          = 'F': H = H(1) H(2) . . . H(k) (Forward) */
-/*          = 'B': H = H(k) . . . H(2) H(1) (Backward) */
-
-/*  STOREV  (input) CHARACTER*1 */
-/*          Indicates how the vectors which define the elementary */
-/*          reflectors are stored: */
-/*          = 'C': Columnwise */
-/*          = 'R': Rowwise */
-
-/*  M       (input) INTEGER */
-/*          The number of rows of the matrix C. */
-
-/*  N       (input) INTEGER */
-/*          The number of columns of the matrix C. */
-
-/*  K       (input) INTEGER */
-/*          The order of the matrix T (= the number of elementary */
-/*          reflectors whose product defines the block reflector). */
-
-/*  V       (input) DOUBLE PRECISION array, dimension */
-/*                                (LDV,K) if STOREV = 'C' */
-/*                                (LDV,M) if STOREV = 'R' and SIDE = 'L' */
-/*                                (LDV,N) if STOREV = 'R' and SIDE = 'R' */
-/*          The matrix V. See further details. */
-
-/*  LDV     (input) INTEGER */
-/*          The leading dimension of the array V. */
-/*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
-/*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
-/*          if STOREV = 'R', LDV >= K. */
-
-/*  T       (input) DOUBLE PRECISION array, dimension (LDT,K) */
-/*          The triangular k by k matrix T in the representation of the */
-/*          block reflector. */
-
-/*  LDT     (input) INTEGER */
-/*          The leading dimension of the array T. LDT >= K. */
-
-/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
-/*          On entry, the m by n matrix C. */
-/*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
-
-/*  LDC     (input) INTEGER */
-/*          The leading dimension of the array C. LDA >= max(1,M). */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) */
-
-/*  LDWORK  (input) INTEGER */
-/*          The leading dimension of the array WORK. */
-/*          If SIDE = 'L', LDWORK >= max(1,N); */
-/*          if SIDE = 'R', LDWORK >= max(1,M). */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Quick return if possible */
-
-    /* Parameter adjustments */
-    v_dim1 = *ldv;
-    v_offset = 1 + v_dim1;
-    v -= v_offset;
-    t_dim1 = *ldt;
-    t_offset = 1 + t_dim1;
-    t -= t_offset;
-    c_dim1 = *ldc;
-    c_offset = 1 + c_dim1;
-    c__ -= c_offset;
-    work_dim1 = *ldwork;
-    work_offset = 1 + work_dim1;
-    work -= work_offset;
-
-    /* Function Body */
-    if (*m <= 0 || *n <= 0) {
-	return 0;
-    }
-
-    if (lsame_(trans, "N")) {
-	*(unsigned char *)transt = 'T';
-    } else {
-	*(unsigned char *)transt = 'N';
-    }
-
-    if (lsame_(storev, "C")) {
-
-	if (lsame_(direct, "F")) {
-
-/*           Let  V =  ( V1 )    (first K rows) */
-/*                     ( V2 ) */
-/*           where  V1  is unit lower triangular. */
-
-	    if (lsame_(side, "L")) {
-
-/*              Form  H * C  or  H' * C  where  C = ( C1 ) */
-/*                                                  ( C2 ) */
-
-/* Computing MAX */
-		i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv);
-		lastv = max(i__1,i__2);
-		lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
-
-/*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK) */
-
-/*              W := C1' */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 
-			    + 1], &c__1);
-/* L10: */
-		}
-
-/*              W := W * V1 */
-
-		dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
-			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
-		if (lastv > *k) {
-
-/*                 W := W + C2'*V2 */
-
-		    i__1 = lastv - *k;
-		    dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
-			    c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + 
-			    v_dim1], ldv, &c_b14, &work[work_offset], ldwork);
-		}
-
-/*              W := W * T'  or  W * T */
-
-		dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
-			c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
-
-/*              C := C - V * W' */
-
-		if (lastv > *k) {
-
-/*                 C2 := C2 - V2 * W' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
-			    c_b25, &v[*k + 1 + v_dim1], ldv, &work[
-			    work_offset], ldwork, &c_b14, &c__[*k + 1 + 
-			    c_dim1], ldc);
-		}
-
-/*              W := W * V1' */
-
-		dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
-			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
-
-/*              C1 := C1 - W' */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    i__2 = lastc;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
-/* L20: */
-		    }
-/* L30: */
-		}
-
-	    } else if (lsame_(side, "R")) {
-
-/*              Form  C * H  or  C * H'  where  C = ( C1  C2 ) */
-
-/* Computing MAX */
-		i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv);
-		lastv = max(i__1,i__2);
-		lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
-
-/*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK) */
-
-/*              W := C1 */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * 
-			    work_dim1 + 1], &c__1);
-/* L40: */
-		}
-
-/*              W := W * V1 */
-
-		dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
-			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
-		if (lastv > *k) {
-
-/*                 W := W + C2 * V2 */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
-			    c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 
-			    1 + v_dim1], ldv, &c_b14, &work[work_offset], 
-			    ldwork);
-		}
-
-/*              W := W * T  or  W * T' */
-
-		dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, 
-			 &t[t_offset], ldt, &work[work_offset], ldwork);
-
-/*              C := C - W * V' */
-
-		if (lastv > *k) {
-
-/*                 C2 := C2 - W * V2' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
-			    c_b25, &work[work_offset], ldwork, &v[*k + 1 + 
-			    v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], 
-			     ldc);
-		}
-
-/*              W := W * V1' */
-
-		dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
-			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
-
-/*              C1 := C1 - W */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    i__2 = lastc;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
-/* L50: */
-		    }
-/* L60: */
-		}
-	    }
-
-	} else {
-
-/*           Let  V =  ( V1 ) */
-/*                     ( V2 )    (last K rows) */
-/*           where  V2  is unit upper triangular. */
-
-	    if (lsame_(side, "L")) {
-
-/*              Form  H * C  or  H' * C  where  C = ( C1 ) */
-/*                                                  ( C2 ) */
-
-/* Computing MAX */
-		i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv);
-		lastv = max(i__1,i__2);
-		lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
-
-/*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK) */
-
-/*              W := C2' */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
-			    j * work_dim1 + 1], &c__1);
-/* L70: */
-		}
-
-/*              W := W * V2 */
-
-		dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
-			c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
-			work_offset], ldwork);
-		if (lastv > *k) {
-
-/*                 W := W + C1'*V1 */
-
-		    i__1 = lastv - *k;
-		    dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
-			    c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
-			    c_b14, &work[work_offset], ldwork);
-		}
-
-/*              W := W * T'  or  W * T */
-
-		dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
-			c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
-
-/*              C := C - V * W' */
-
-		if (lastv > *k) {
-
-/*                 C1 := C1 - V1 * W' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
-			    c_b25, &v[v_offset], ldv, &work[work_offset], 
-			    ldwork, &c_b14, &c__[c_offset], ldc);
-		}
-
-/*              W := W * V2' */
-
-		dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
-			c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
-			work_offset], ldwork);
-
-/*              C2 := C2 - W' */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    i__2 = lastc;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * 
-				work_dim1];
-/* L80: */
-		    }
-/* L90: */
-		}
-
-	    } else if (lsame_(side, "R")) {
-
-/*              Form  C * H  or  C * H'  where  C = ( C1  C2 ) */
-
-/* Computing MAX */
-		i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv);
-		lastv = max(i__1,i__2);
-		lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
-
-/*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK) */
-
-/*              W := C2 */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    dcopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &
-			    work[j * work_dim1 + 1], &c__1);
-/* L100: */
-		}
-
-/*              W := W * V2 */
-
-		dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
-			c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
-			work_offset], ldwork);
-		if (lastv > *k) {
-
-/*                 W := W + C1 * V1 */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
-			    c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
-			    c_b14, &work[work_offset], ldwork);
-		}
-
-/*              W := W * T  or  W * T' */
-
-		dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, 
-			 &t[t_offset], ldt, &work[work_offset], ldwork);
-
-/*              C := C - W * V' */
-
-		if (lastv > *k) {
-
-/*                 C1 := C1 - W * V1' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
-			    c_b25, &work[work_offset], ldwork, &v[v_offset], 
-			    ldv, &c_b14, &c__[c_offset], ldc);
-		}
-
-/*              W := W * V2' */
-
-		dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
-			c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
-			work_offset], ldwork);
-
-/*              C2 := C2 - W */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    i__2 = lastc;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
-				 work_dim1];
-/* L110: */
-		    }
-/* L120: */
-		}
-	    }
-	}
-
-    } else if (lsame_(storev, "R")) {
-
-	if (lsame_(direct, "F")) {
-
-/*           Let  V =  ( V1  V2 )    (V1: first K columns) */
-/*           where  V1  is unit upper triangular. */
-
-	    if (lsame_(side, "L")) {
-
-/*              Form  H * C  or  H' * C  where  C = ( C1 ) */
-/*                                                  ( C2 ) */
-
-/* Computing MAX */
-		i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv);
-		lastv = max(i__1,i__2);
-		lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
-
-/*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK) */
-
-/*              W := C1' */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 
-			    + 1], &c__1);
-/* L130: */
-		}
-
-/*              W := W * V1' */
-
-		dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
-			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
-		if (lastv > *k) {
-
-/*                 W := W + C2'*V2' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, 
-			     &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 
-			    + 1], ldv, &c_b14, &work[work_offset], ldwork);
-		}
-
-/*              W := W * T'  or  W * T */
-
-		dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
-			c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
-
-/*              C := C - V' * W' */
-
-		if (lastv > *k) {
-
-/*                 C2 := C2 - V2' * W' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, 
-			     &v[(*k + 1) * v_dim1 + 1], ldv, &work[
-			    work_offset], ldwork, &c_b14, &c__[*k + 1 + 
-			    c_dim1], ldc);
-		}
-
-/*              W := W * V1 */
-
-		dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
-			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
-
-/*              C1 := C1 - W' */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    i__2 = lastc;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
-/* L140: */
-		    }
-/* L150: */
-		}
-
-	    } else if (lsame_(side, "R")) {
-
-/*              Form  C * H  or  C * H'  where  C = ( C1  C2 ) */
-
-/* Computing MAX */
-		i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv);
-		lastv = max(i__1,i__2);
-		lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
-
-/*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK) */
-
-/*              W := C1 */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * 
-			    work_dim1 + 1], &c__1);
-/* L160: */
-		}
-
-/*              W := W * V1' */
-
-		dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
-			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
-		if (lastv > *k) {
-
-/*                 W := W + C2 * V2' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
-			    c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 
-			    1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], 
-			     ldwork);
-		}
-
-/*              W := W * T  or  W * T' */
-
-		dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, 
-			 &t[t_offset], ldt, &work[work_offset], ldwork);
-
-/*              C := C - W * V */
-
-		if (lastv > *k) {
-
-/*                 C2 := C2 - W * V2 */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
-			    c_b25, &work[work_offset], ldwork, &v[(*k + 1) * 
-			    v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 
-			    + 1], ldc);
-		}
-
-/*              W := W * V1 */
-
-		dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
-			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
-
-/*              C1 := C1 - W */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    i__2 = lastc;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
-/* L170: */
-		    }
-/* L180: */
-		}
-
-	    }
-
-	} else {
-
-/*           Let  V =  ( V1  V2 )    (V2: last K columns) */
-/*           where  V2  is unit lower triangular. */
-
-	    if (lsame_(side, "L")) {
-
-/*              Form  H * C  or  H' * C  where  C = ( C1 ) */
-/*                                                  ( C2 ) */
-
-/* Computing MAX */
-		i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv);
-		lastv = max(i__1,i__2);
-		lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
-
-/*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK) */
-
-/*              W := C2' */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
-			    j * work_dim1 + 1], &c__1);
-/* L190: */
-		}
-
-/*              W := W * V2' */
-
-		dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
-			c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
-			work_offset], ldwork);
-		if (lastv > *k) {
-
-/*                 W := W + C1'*V1' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, 
-			     &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
-			    work[work_offset], ldwork);
-		}
-
-/*              W := W * T'  or  W * T */
-
-		dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
-			c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
-
-/*              C := C - V' * W' */
-
-		if (lastv > *k) {
-
-/*                 C1 := C1 - V1' * W' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, 
-			     &v[v_offset], ldv, &work[work_offset], ldwork, &
-			    c_b14, &c__[c_offset], ldc);
-		}
-
-/*              W := W * V2 */
-
-		dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
-			c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
-			work_offset], ldwork);
-
-/*              C2 := C2 - W' */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    i__2 = lastc;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * 
-				work_dim1];
-/* L200: */
-		    }
-/* L210: */
-		}
-
-	    } else if (lsame_(side, "R")) {
-
-/*              Form  C * H  or  C * H'  where  C = ( C1  C2 ) */
-
-/* Computing MAX */
-		i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv);
-		lastv = max(i__1,i__2);
-		lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
-
-/*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK) */
-
-/*              W := C2 */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    dcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, 
-			     &work[j * work_dim1 + 1], &c__1);
-/* L220: */
-		}
-
-/*              W := W * V2' */
-
-		dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
-			c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
-			work_offset], ldwork);
-		if (lastv > *k) {
-
-/*                 W := W + C1 * V1' */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
-			    c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
-			    c_b14, &work[work_offset], ldwork);
-		}
-
-/*              W := W * T  or  W * T' */
-
-		dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, 
-			 &t[t_offset], ldt, &work[work_offset], ldwork);
-
-/*              C := C - W * V */
-
-		if (lastv > *k) {
-
-/*                 C1 := C1 - W * V1 */
-
-		    i__1 = lastv - *k;
-		    dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
-			    c_b25, &work[work_offset], ldwork, &v[v_offset], 
-			    ldv, &c_b14, &c__[c_offset], ldc);
-		}
-
-/*              W := W * V2 */
-
-		dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
-			c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
-			work_offset], ldwork);
-
-/*              C1 := C1 - W */
-
-		i__1 = *k;
-		for (j = 1; j <= i__1; ++j) {
-		    i__2 = lastc;
-		    for (i__ = 1; i__ <= i__2; ++i__) {
-			c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
-				 work_dim1];
-/* L230: */
-		    }
-/* L240: */
-		}
-
-	    }
-
-	}
-    }
-
-    return 0;
-
-/*     End of DLARFB */
-
-} /* dlarfb_ */

3rdparty/lapack/dlarfg.c

@@ -1,170 +0,0 @@
-/* dlarfg.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, 
-	integer *incx, doublereal *tau)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double d_sign(doublereal *, doublereal *);
-
-    /* Local variables */
-    integer j, knt;
-    doublereal beta;
-    extern doublereal dnrm2_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
-	    integer *);
-    doublereal xnorm;
-    extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
-    doublereal safmin, rsafmn;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLARFG generates a real elementary reflector H of order n, such */
-/*  that */
-
-/*        H * ( alpha ) = ( beta ),   H' * H = I. */
-/*            (   x   )   (   0  ) */
-
-/*  where alpha and beta are scalars, and x is an (n-1)-element real */
-/*  vector. H is represented in the form */
-
-/*        H = I - tau * ( 1 ) * ( 1 v' ) , */
-/*                      ( v ) */
-
-/*  where tau is a real scalar and v is a real (n-1)-element */
-/*  vector. */
-
-/*  If the elements of x are all zero, then tau = 0 and H is taken to be */
-/*  the unit matrix. */
-
-/*  Otherwise  1 <= tau <= 2. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the elementary reflector. */
-
-/*  ALPHA   (input/output) DOUBLE PRECISION */
-/*          On entry, the value alpha. */
-/*          On exit, it is overwritten with the value beta. */
-
-/*  X       (input/output) DOUBLE PRECISION array, dimension */
-/*                         (1+(N-2)*abs(INCX)) */
-/*          On entry, the vector x. */
-/*          On exit, it is overwritten with the vector v. */
-
-/*  INCX    (input) INTEGER */
-/*          The increment between elements of X. INCX > 0. */
-
-/*  TAU     (output) DOUBLE PRECISION */
-/*          The value tau. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --x;
-
-    /* Function Body */
-    if (*n <= 1) {
-	*tau = 0.;
-	return 0;
-    }
-
-    i__1 = *n - 1;
-    xnorm = dnrm2_(&i__1, &x[1], incx);
-
-    if (xnorm == 0.) {
-
-/*        H  =  I */
-
-	*tau = 0.;
-    } else {
-
-/*        general case */
-
-	d__1 = dlapy2_(alpha, &xnorm);
-	beta = -d_sign(&d__1, alpha);
-	safmin = dlamch_("S") / dlamch_("E");
-	knt = 0;
-	if (abs(beta) < safmin) {
-
-/*           XNORM, BETA may be inaccurate; scale X and recompute them */
-
-	    rsafmn = 1. / safmin;
-L10:
-	    ++knt;
-	    i__1 = *n - 1;
-	    dscal_(&i__1, &rsafmn, &x[1], incx);
-	    beta *= rsafmn;
-	    *alpha *= rsafmn;
-	    if (abs(beta) < safmin) {
-		goto L10;
-	    }
-
-/*           New BETA is at most 1, at least SAFMIN */
-
-	    i__1 = *n - 1;
-	    xnorm = dnrm2_(&i__1, &x[1], incx);
-	    d__1 = dlapy2_(alpha, &xnorm);
-	    beta = -d_sign(&d__1, alpha);
-	}
-	*tau = (beta - *alpha) / beta;
-	i__1 = *n - 1;
-	d__1 = 1. / (*alpha - beta);
-	dscal_(&i__1, &d__1, &x[1], incx);
-
-/*        If ALPHA is subnormal, it may lose relative accuracy */
-
-	i__1 = knt;
-	for (j = 1; j <= i__1; ++j) {
-	    beta *= safmin;
-/* L20: */
-	}
-	*alpha = beta;
-    }
-
-    return 0;
-
-/*     End of DLARFG */
-
-} /* dlarfg_ */

3rdparty/lapack/dlarfp.c

@@ -1,192 +0,0 @@
-/* dlarfp.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarfp_(integer *n, doublereal *alpha, doublereal *x, 
-	integer *incx, doublereal *tau)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double d_sign(doublereal *, doublereal *);
-
-    /* Local variables */
-    integer j, knt;
-    doublereal beta;
-    extern doublereal dnrm2_(integer *, doublereal *, integer *);
-    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
-	    integer *);
-    doublereal xnorm;
-    extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
-    doublereal safmin, rsafmn;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLARFP generates a real elementary reflector H of order n, such */
-/*  that */
-
-/*        H * ( alpha ) = ( beta ),   H' * H = I. */
-/*            (   x   )   (   0  ) */
-
-/*  where alpha and beta are scalars, beta is non-negative, and x is */
-/*  an (n-1)-element real vector.  H is represented in the form */
-
-/*        H = I - tau * ( 1 ) * ( 1 v' ) , */
-/*                      ( v ) */
-
-/*  where tau is a real scalar and v is a real (n-1)-element */
-/*  vector. */
-
-/*  If the elements of x are all zero, then tau = 0 and H is taken to be */
-/*  the unit matrix. */
-
-/*  Otherwise  1 <= tau <= 2. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the elementary reflector. */
-
-/*  ALPHA   (input/output) DOUBLE PRECISION */
-/*          On entry, the value alpha. */
-/*          On exit, it is overwritten with the value beta. */
-
-/*  X       (input/output) DOUBLE PRECISION array, dimension */
-/*                         (1+(N-2)*abs(INCX)) */
-/*          On entry, the vector x. */
-/*          On exit, it is overwritten with the vector v. */
-
-/*  INCX    (input) INTEGER */
-/*          The increment between elements of X. INCX > 0. */
-
-/*  TAU     (output) DOUBLE PRECISION */
-/*          The value tau. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --x;
-
-    /* Function Body */
-    if (*n <= 0) {
-	*tau = 0.;
-	return 0;
-    }
-
-    i__1 = *n - 1;
-    xnorm = dnrm2_(&i__1, &x[1], incx);
-
-    if (xnorm == 0.) {
-
-/*        H  =  [+/-1, 0; I], sign chosen so ALPHA >= 0 */
-
-	if (*alpha >= 0.) {
-/*           When TAU.eq.ZERO, the vector is special-cased to be */
-/*           all zeros in the application routines.  We do not need */
-/*           to clear it. */
-	    *tau = 0.;
-	} else {
-/*           However, the application routines rely on explicit */
-/*           zero checks when TAU.ne.ZERO, and we must clear X. */
-	    *tau = 2.;
-	    i__1 = *n - 1;
-	    for (j = 1; j <= i__1; ++j) {
-		x[(j - 1) * *incx + 1] = 0.;
-	    }
-	    *alpha = -(*alpha);
-	}
-    } else {
-
-/*        general case */
-
-	d__1 = dlapy2_(alpha, &xnorm);
-	beta = d_sign(&d__1, alpha);
-	safmin = dlamch_("S") / dlamch_("E");
-	knt = 0;
-	if (abs(beta) < safmin) {
-
-/*           XNORM, BETA may be inaccurate; scale X and recompute them */
-
-	    rsafmn = 1. / safmin;
-L10:
-	    ++knt;
-	    i__1 = *n - 1;
-	    dscal_(&i__1, &rsafmn, &x[1], incx);
-	    beta *= rsafmn;
-	    *alpha *= rsafmn;
-	    if (abs(beta) < safmin) {
-		goto L10;
-	    }
-
-/*           New BETA is at most 1, at least SAFMIN */
-
-	    i__1 = *n - 1;
-	    xnorm = dnrm2_(&i__1, &x[1], incx);
-	    d__1 = dlapy2_(alpha, &xnorm);
-	    beta = d_sign(&d__1, alpha);
-	}
-	*alpha += beta;
-	if (beta < 0.) {
-	    beta = -beta;
-	    *tau = -(*alpha) / beta;
-	} else {
-	    *alpha = xnorm * (xnorm / *alpha);
-	    *tau = *alpha / beta;
-	    *alpha = -(*alpha);
-	}
-	i__1 = *n - 1;
-	d__1 = 1. / *alpha;
-	dscal_(&i__1, &d__1, &x[1], incx);
-
-/*        If BETA is subnormal, it may lose relative accuracy */
-
-	i__1 = knt;
-	for (j = 1; j <= i__1; ++j) {
-	    beta *= safmin;
-/* L20: */
-	}
-	*alpha = beta;
-    }
-
-    return 0;
-
-/*     End of DLARFP */
-
-} /* dlarfp_ */

3rdparty/lapack/dlarft.c

@@ -1,325 +0,0 @@
-/* dlarft.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static doublereal c_b8 = 0.;
-
-/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *
-	k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, 
-	integer *ldt)
-{
-    /* System generated locals */
-    integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
-    doublereal d__1;
-
-    /* Local variables */
-    integer i__, j, prevlastv;
-    doublereal vii;
-    extern logical lsame_(char *, char *);
-    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
-	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
-	    doublereal *, doublereal *, integer *);
-    integer lastv;
-    extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, 
-	    doublereal *, integer *, doublereal *, integer *);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLARFT forms the triangular factor T of a real block reflector H */
-/*  of order n, which is defined as a product of k elementary reflectors. */
-
-/*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
-
-/*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
-
-/*  If STOREV = 'C', the vector which defines the elementary reflector */
-/*  H(i) is stored in the i-th column of the array V, and */
-
-/*     H  =  I - V * T * V' */
-
-/*  If STOREV = 'R', the vector which defines the elementary reflector */
-/*  H(i) is stored in the i-th row of the array V, and */
-
-/*     H  =  I - V' * T * V */
-
-/*  Arguments */
-/*  ========= */
-
-/*  DIRECT  (input) CHARACTER*1 */
-/*          Specifies the order in which the elementary reflectors are */
-/*          multiplied to form the block reflector: */
-/*          = 'F': H = H(1) H(2) . . . H(k) (Forward) */
-/*          = 'B': H = H(k) . . . H(2) H(1) (Backward) */
-
-/*  STOREV  (input) CHARACTER*1 */
-/*          Specifies how the vectors which define the elementary */
-/*          reflectors are stored (see also Further Details): */
-/*          = 'C': columnwise */
-/*          = 'R': rowwise */
-
-/*  N       (input) INTEGER */
-/*          The order of the block reflector H. N >= 0. */
-
-/*  K       (input) INTEGER */
-/*          The order of the triangular factor T (= the number of */
-/*          elementary reflectors). K >= 1. */
-
-/*  V       (input/output) DOUBLE PRECISION array, dimension */
-/*                               (LDV,K) if STOREV = 'C' */
-/*                               (LDV,N) if STOREV = 'R' */
-/*          The matrix V. See further details. */
-
-/*  LDV     (input) INTEGER */
-/*          The leading dimension of the array V. */
-/*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
-
-/*  TAU     (input) DOUBLE PRECISION array, dimension (K) */
-/*          TAU(i) must contain the scalar factor of the elementary */
-/*          reflector H(i). */
-
-/*  T       (output) DOUBLE PRECISION array, dimension (LDT,K) */
-/*          The k by k triangular factor T of the block reflector. */
-/*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
-/*          lower triangular. The rest of the array is not used. */
-
-/*  LDT     (input) INTEGER */
-/*          The leading dimension of the array T. LDT >= K. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  The shape of the matrix V and the storage of the vectors which define */
-/*  the H(i) is best illustrated by the following example with n = 5 and */
-/*  k = 3. The elements equal to 1 are not stored; the corresponding */
-/*  array elements are modified but restored on exit. The rest of the */
-/*  array is not used. */
-
-/*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R': */
-
-/*               V = (  1       )                 V = (  1 v1 v1 v1 v1 ) */
-/*                   ( v1  1    )                     (     1 v2 v2 v2 ) */
-/*                   ( v1 v2  1 )                     (        1 v3 v3 ) */
-/*                   ( v1 v2 v3 ) */
-/*                   ( v1 v2 v3 ) */
-
-/*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R': */
-
-/*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       ) */
-/*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    ) */
-/*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 ) */
-/*                   (     1 v3 ) */
-/*                   (        1 ) */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Quick return if possible */
-
-    /* Parameter adjustments */
-    v_dim1 = *ldv;
-    v_offset = 1 + v_dim1;
-    v -= v_offset;
-    --tau;
-    t_dim1 = *ldt;
-    t_offset = 1 + t_dim1;
-    t -= t_offset;
-
-    /* Function Body */
-    if (*n == 0) {
-	return 0;
-    }
-
-    if (lsame_(direct, "F")) {
-	prevlastv = *n;
-	i__1 = *k;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    prevlastv = max(i__,prevlastv);
-	    if (tau[i__] == 0.) {
-
-/*              H(i)  =  I */
-
-		i__2 = i__;
-		for (j = 1; j <= i__2; ++j) {
-		    t[j + i__ * t_dim1] = 0.;
-/* L10: */
-		}
-	    } else {
-
-/*              general case */
-
-		vii = v[i__ + i__ * v_dim1];
-		v[i__ + i__ * v_dim1] = 1.;
-		if (lsame_(storev, "C")) {
-/*                 Skip any trailing zeros. */
-		    i__2 = i__ + 1;
-		    for (lastv = *n; lastv >= i__2; --lastv) {
-			if (v[lastv + i__ * v_dim1] != 0.) {
-			    break;
-			}
-		    }
-		    j = min(lastv,prevlastv);
-
-/*                 T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */
-
-		    i__2 = j - i__ + 1;
-		    i__3 = i__ - 1;
-		    d__1 = -tau[i__];
-		    dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1], 
-			     ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[
-			    i__ * t_dim1 + 1], &c__1);
-		} else {
-/*                 Skip any trailing zeros. */
-		    i__2 = i__ + 1;
-		    for (lastv = *n; lastv >= i__2; --lastv) {
-			if (v[i__ + lastv * v_dim1] != 0.) {
-			    break;
-			}
-		    }
-		    j = min(lastv,prevlastv);
-
-/*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */
-
-		    i__2 = i__ - 1;
-		    i__3 = j - i__ + 1;
-		    d__1 = -tau[i__];
-		    dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ * 
-			    v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
-			    c_b8, &t[i__ * t_dim1 + 1], &c__1);
-		}
-		v[i__ + i__ * v_dim1] = vii;
-
-/*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
-
-		i__2 = i__ - 1;
-		dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
-			t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
-		t[i__ + i__ * t_dim1] = tau[i__];
-		if (i__ > 1) {
-		    prevlastv = max(prevlastv,lastv);
-		} else {
-		    prevlastv = lastv;
-		}
-	    }
-/* L20: */
-	}
-    } else {
-	prevlastv = 1;
-	for (i__ = *k; i__ >= 1; --i__) {
-	    if (tau[i__] == 0.) {
-
-/*              H(i)  =  I */
-
-		i__1 = *k;
-		for (j = i__; j <= i__1; ++j) {
-		    t[j + i__ * t_dim1] = 0.;
-/* L30: */
-		}
-	    } else {
-
-/*              general case */
-
-		if (i__ < *k) {
-		    if (lsame_(storev, "C")) {
-			vii = v[*n - *k + i__ + i__ * v_dim1];
-			v[*n - *k + i__ + i__ * v_dim1] = 1.;
-/*                    Skip any leading zeros. */
-			i__1 = i__ - 1;
-			for (lastv = 1; lastv <= i__1; ++lastv) {
-			    if (v[lastv + i__ * v_dim1] != 0.) {
-				break;
-			    }
-			}
-			j = max(lastv,prevlastv);
-
-/*                    T(i+1:k,i) := */
-/*                            - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */
-
-			i__1 = *n - *k + i__ - j + 1;
-			i__2 = *k - i__;
-			d__1 = -tau[i__];
-			dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__ 
-				+ 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
-				c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
-				c__1);
-			v[*n - *k + i__ + i__ * v_dim1] = vii;
-		    } else {
-			vii = v[i__ + (*n - *k + i__) * v_dim1];
-			v[i__ + (*n - *k + i__) * v_dim1] = 1.;
-/*                    Skip any leading zeros. */
-			i__1 = i__ - 1;
-			for (lastv = 1; lastv <= i__1; ++lastv) {
-			    if (v[i__ + lastv * v_dim1] != 0.) {
-				break;
-			    }
-			}
-			j = max(lastv,prevlastv);
-
-/*                    T(i+1:k,i) := */
-/*                            - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */
-
-			i__1 = *k - i__;
-			i__2 = *n - *k + i__ - j + 1;
-			d__1 = -tau[i__];
-			dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + 
-				1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], 
-				ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1);
-			v[i__ + (*n - *k + i__) * v_dim1] = vii;
-		    }
-
-/*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
-
-		    i__1 = *k - i__;
-		    dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ 
-			    + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
-			     t_dim1], &c__1)
-			    ;
-		    if (i__ > 1) {
-			prevlastv = min(prevlastv,lastv);
-		    } else {
-			prevlastv = lastv;
-		    }
-		}
-		t[i__ + i__ * t_dim1] = tau[i__];
-	    }
-/* L40: */
-	}
-    }
-    return 0;
-
-/*     End of DLARFT */
-
-} /* dlarft_ */

3rdparty/lapack/dlarnv.c

@@ -1,146 +0,0 @@
-/* dlarnv.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarnv_(integer *idist, integer *iseed, integer *n, 
-	doublereal *x)
-{
-    /* System generated locals */
-    integer i__1, i__2, i__3;
-
-    /* Builtin functions */
-    double log(doublereal), sqrt(doublereal), cos(doublereal);
-
-    /* Local variables */
-    integer i__;
-    doublereal u[128];
-    integer il, iv, il2;
-    extern /* Subroutine */ int dlaruv_(integer *, integer *, doublereal *);
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLARNV returns a vector of n random real numbers from a uniform or */
-/*  normal distribution. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  IDIST   (input) INTEGER */
-/*          Specifies the distribution of the random numbers: */
-/*          = 1:  uniform (0,1) */
-/*          = 2:  uniform (-1,1) */
-/*          = 3:  normal (0,1) */
-
-/*  ISEED   (input/output) INTEGER array, dimension (4) */
-/*          On entry, the seed of the random number generator; the array */
-/*          elements must be between 0 and 4095, and ISEED(4) must be */
-/*          odd. */
-/*          On exit, the seed is updated. */
-
-/*  N       (input) INTEGER */
-/*          The number of random numbers to be generated. */
-
-/*  X       (output) DOUBLE PRECISION array, dimension (N) */
-/*          The generated random numbers. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  This routine calls the auxiliary routine DLARUV to generate random */
-/*  real numbers from a uniform (0,1) distribution, in batches of up to */
-/*  128 using vectorisable code. The Box-Muller method is used to */
-/*  transform numbers from a uniform to a normal distribution. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Local Arrays .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --x;
-    --iseed;
-
-    /* Function Body */
-    i__1 = *n;
-    for (iv = 1; iv <= i__1; iv += 64) {
-/* Computing MIN */
-	i__2 = 64, i__3 = *n - iv + 1;
-	il = min(i__2,i__3);
-	if (*idist == 3) {
-	    il2 = il << 1;
-	} else {
-	    il2 = il;
-	}
-
-/*        Call DLARUV to generate IL2 numbers from a uniform (0,1) */
-/*        distribution (IL2 <= LV) */
-
-	dlaruv_(&iseed[1], &il2, u);
-
-	if (*idist == 1) {
-
-/*           Copy generated numbers */
-
-	    i__2 = il;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		x[iv + i__ - 1] = u[i__ - 1];
-/* L10: */
-	    }
-	} else if (*idist == 2) {
-
-/*           Convert generated numbers to uniform (-1,1) distribution */
-
-	    i__2 = il;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		x[iv + i__ - 1] = u[i__ - 1] * 2. - 1.;
-/* L20: */
-	    }
-	} else if (*idist == 3) {
-
-/*           Convert generated numbers to normal (0,1) distribution */
-
-	    i__2 = il;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		x[iv + i__ - 1] = sqrt(log(u[(i__ << 1) - 2]) * -2.) * cos(u[(
-			i__ << 1) - 1] * 6.2831853071795864769252867663);
-/* L30: */
-	    }
-	}
-/* L40: */
-    }
-    return 0;
-
-/*     End of DLARNV */
-
-} /* dlarnv_ */

3rdparty/lapack/dlarra.c

@@ -1,156 +0,0 @@
-/* dlarra.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarra_(integer *n, doublereal *d__, doublereal *e, 
-	doublereal *e2, doublereal *spltol, doublereal *tnrm, integer *nsplit, 
-	 integer *isplit, integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1, d__2;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    integer i__;
-    doublereal tmp1, eabs;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  Compute the splitting points with threshold SPLTOL. */
-/*  DLARRA sets any "small" off-diagonal elements to zero. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix. N > 0. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the N diagonal elements of the tridiagonal */
-/*          matrix T. */
-
-/*  E       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the first (N-1) entries contain the subdiagonal */
-/*          elements of the tridiagonal matrix T; E(N) need not be set. */
-/*          On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, */
-/*          are set to zero, the other entries of E are untouched. */
-
-/*  E2      (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the first (N-1) entries contain the SQUARES of the */
-/*          subdiagonal elements of the tridiagonal matrix T; */
-/*          E2(N) need not be set. */
-/*          On exit, the entries E2( ISPLIT( I ) ), */
-/*          1 <= I <= NSPLIT, have been set to zero */
-
-/*  SPLTOL (input) DOUBLE PRECISION */
-/*          The threshold for splitting. Two criteria can be used: */
-/*          SPLTOL<0 : criterion based on absolute off-diagonal value */
-/*          SPLTOL>0 : criterion that preserves relative accuracy */
-
-/*  TNRM (input) DOUBLE PRECISION */
-/*          The norm of the matrix. */
-
-/*  NSPLIT  (output) INTEGER */
-/*          The number of blocks T splits into. 1 <= NSPLIT <= N. */
-
-/*  ISPLIT  (output) INTEGER array, dimension (N) */
-/*          The splitting points, at which T breaks up into blocks. */
-/*          The first block consists of rows/columns 1 to ISPLIT(1), */
-/*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
-/*          etc., and the NSPLIT-th consists of rows/columns */
-/*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
-
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --isplit;
-    --e2;
-    --e;
-    --d__;
-
-    /* Function Body */
-    *info = 0;
-/*     Compute splitting points */
-    *nsplit = 1;
-    if (*spltol < 0.) {
-/*        Criterion based on absolute off-diagonal value */
-	tmp1 = abs(*spltol) * *tnrm;
-	i__1 = *n - 1;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    eabs = (d__1 = e[i__], abs(d__1));
-	    if (eabs <= tmp1) {
-		e[i__] = 0.;
-		e2[i__] = 0.;
-		isplit[*nsplit] = i__;
-		++(*nsplit);
-	    }
-/* L9: */
-	}
-    } else {
-/*        Criterion that guarantees relative accuracy */
-	i__1 = *n - 1;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    eabs = (d__1 = e[i__], abs(d__1));
-	    if (eabs <= *spltol * sqrt((d__1 = d__[i__], abs(d__1))) * sqrt((
-		    d__2 = d__[i__ + 1], abs(d__2)))) {
-		e[i__] = 0.;
-		e2[i__] = 0.;
-		isplit[*nsplit] = i__;
-		++(*nsplit);
-	    }
-/* L10: */
-	}
-    }
-    isplit[*nsplit] = *n;
-    return 0;
-
-/*     End of DLARRA */
-
-} /* dlarra_ */

3rdparty/lapack/dlarrb.c

@@ -1,350 +0,0 @@
-/* dlarrb.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarrb_(integer *n, doublereal *d__, doublereal *lld, 
-	integer *ifirst, integer *ilast, doublereal *rtol1, doublereal *rtol2, 
-	 integer *offset, doublereal *w, doublereal *wgap, doublereal *werr, 
-	doublereal *work, integer *iwork, doublereal *pivmin, doublereal *
-	spdiam, integer *twist, integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1, d__2;
-
-    /* Builtin functions */
-    double log(doublereal);
-
-    /* Local variables */
-    integer i__, k, r__, i1, ii, ip;
-    doublereal gap, mid, tmp, back, lgap, rgap, left;
-    integer iter, nint, prev, next;
-    doublereal cvrgd, right, width;
-    extern integer dlaneg_(integer *, doublereal *, doublereal *, doublereal *
-, doublereal *, integer *);
-    integer negcnt;
-    doublereal mnwdth;
-    integer olnint, maxitr;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  Given the relatively robust representation(RRR) L D L^T, DLARRB */
-/*  does "limited" bisection to refine the eigenvalues of L D L^T, */
-/*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */
-/*  guesses for these eigenvalues are input in W, the corresponding estimate */
-/*  of the error in these guesses and their gaps are input in WERR */
-/*  and WGAP, respectively. During bisection, intervals */
-/*  [left, right] are maintained by storing their mid-points and */
-/*  semi-widths in the arrays W and WERR respectively. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The N diagonal elements of the diagonal matrix D. */
-
-/*  LLD     (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The (N-1) elements L(i)*L(i)*D(i). */
-
-/*  IFIRST  (input) INTEGER */
-/*          The index of the first eigenvalue to be computed. */
-
-/*  ILAST   (input) INTEGER */
-/*          The index of the last eigenvalue to be computed. */
-
-/*  RTOL1   (input) DOUBLE PRECISION */
-/*  RTOL2   (input) DOUBLE PRECISION */
-/*          Tolerance for the convergence of the bisection intervals. */
-/*          An interval [LEFT,RIGHT] has converged if */
-/*          RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
-/*          where GAP is the (estimated) distance to the nearest */
-/*          eigenvalue. */
-
-/*  OFFSET  (input) INTEGER */
-/*          Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET */
-/*          through ILAST-OFFSET elements of these arrays are to be used. */
-
-/*  W       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */
-/*          estimates of the eigenvalues of L D L^T indexed IFIRST throug */
-/*          ILAST. */
-/*          On output, these estimates are refined. */
-
-/*  WGAP    (input/output) DOUBLE PRECISION array, dimension (N-1) */
-/*          On input, the (estimated) gaps between consecutive */
-/*          eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between */
-/*          eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST */
-/*          then WGAP(IFIRST-OFFSET) must be set to ZERO. */
-/*          On output, these gaps are refined. */
-
-/*  WERR    (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */
-/*          the errors in the estimates of the corresponding elements in W. */
-/*          On output, these errors are refined. */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N) */
-/*          Workspace. */
-
-/*  IWORK   (workspace) INTEGER array, dimension (2*N) */
-/*          Workspace. */
-
-/*  PIVMIN  (input) DOUBLE PRECISION */
-/*          The minimum pivot in the Sturm sequence. */
-
-/*  SPDIAM  (input) DOUBLE PRECISION */
-/*          The spectral diameter of the matrix. */
-
-/*  TWIST   (input) INTEGER */
-/*          The twist index for the twisted factorization that is used */
-/*          for the negcount. */
-/*          TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T */
-/*          TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T */
-/*          TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) */
-
-/*  INFO    (output) INTEGER */
-/*          Error flag. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --iwork;
-    --work;
-    --werr;
-    --wgap;
-    --w;
-    --lld;
-    --d__;
-
-    /* Function Body */
-    *info = 0;
-
-    maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.)) + 
-	    2;
-    mnwdth = *pivmin * 2.;
-
-    r__ = *twist;
-    if (r__ < 1 || r__ > *n) {
-	r__ = *n;
-    }
-
-/*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */
-/*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */
-/*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */
-/*     for an unconverged interval is set to the index of the next unconverged */
-/*     interval, and is -1 or 0 for a converged interval. Thus a linked */
-/*     list of unconverged intervals is set up. */
-
-    i1 = *ifirst;
-/*     The number of unconverged intervals */
-    nint = 0;
-/*     The last unconverged interval found */
-    prev = 0;
-    rgap = wgap[i1 - *offset];
-    i__1 = *ilast;
-    for (i__ = i1; i__ <= i__1; ++i__) {
-	k = i__ << 1;
-	ii = i__ - *offset;
-	left = w[ii] - werr[ii];
-	right = w[ii] + werr[ii];
-	lgap = rgap;
-	rgap = wgap[ii];
-	gap = min(lgap,rgap);
-/*        Make sure that [LEFT,RIGHT] contains the desired eigenvalue */
-/*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT */
-
-/*        Do while( NEGCNT(LEFT).GT.I-1 ) */
-
-	back = werr[ii];
-L20:
-	negcnt = dlaneg_(n, &d__[1], &lld[1], &left, pivmin, &r__);
-	if (negcnt > i__ - 1) {
-	    left -= back;
-	    back *= 2.;
-	    goto L20;
-	}
-
-/*        Do while( NEGCNT(RIGHT).LT.I ) */
-/*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT */
-
-	back = werr[ii];
-L50:
-	negcnt = dlaneg_(n, &d__[1], &lld[1], &right, pivmin, &r__);
-	if (negcnt < i__) {
-	    right += back;
-	    back *= 2.;
-	    goto L50;
-	}
-	width = (d__1 = left - right, abs(d__1)) * .5;
-/* Computing MAX */
-	d__1 = abs(left), d__2 = abs(right);
-	tmp = max(d__1,d__2);
-/* Computing MAX */
-	d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp;
-	cvrgd = max(d__1,d__2);
-	if (width <= cvrgd || width <= mnwdth) {
-/*           This interval has already converged and does not need refinement. */
-/*           (Note that the gaps might change through refining the */
-/*            eigenvalues, however, they can only get bigger.) */
-/*           Remove it from the list. */
-	    iwork[k - 1] = -1;
-/*           Make sure that I1 always points to the first unconverged interval */
-	    if (i__ == i1 && i__ < *ilast) {
-		i1 = i__ + 1;
-	    }
-	    if (prev >= i1 && i__ <= *ilast) {
-		iwork[(prev << 1) - 1] = i__ + 1;
-	    }
-	} else {
-/*           unconverged interval found */
-	    prev = i__;
-	    ++nint;
-	    iwork[k - 1] = i__ + 1;
-	    iwork[k] = negcnt;
-	}
-	work[k - 1] = left;
-	work[k] = right;
-/* L75: */
-    }
-
-/*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */
-/*     and while (ITER.LT.MAXITR) */
-
-    iter = 0;
-L80:
-    prev = i1 - 1;
-    i__ = i1;
-    olnint = nint;
-    i__1 = olnint;
-    for (ip = 1; ip <= i__1; ++ip) {
-	k = i__ << 1;
-	ii = i__ - *offset;
-	rgap = wgap[ii];
-	lgap = rgap;
-	if (ii > 1) {
-	    lgap = wgap[ii - 1];
-	}
-	gap = min(lgap,rgap);
-	next = iwork[k - 1];
-	left = work[k - 1];
-	right = work[k];
-	mid = (left + right) * .5;
-/*        semiwidth of interval */
-	width = right - mid;
-/* Computing MAX */
-	d__1 = abs(left), d__2 = abs(right);
-	tmp = max(d__1,d__2);
-/* Computing MAX */
-	d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp;
-	cvrgd = max(d__1,d__2);
-	if (width <= cvrgd || width <= mnwdth || iter == maxitr) {
-/*           reduce number of unconverged intervals */
-	    --nint;
-/*           Mark interval as converged. */
-	    iwork[k - 1] = 0;
-	    if (i1 == i__) {
-		i1 = next;
-	    } else {
-/*              Prev holds the last unconverged interval previously examined */
-		if (prev >= i1) {
-		    iwork[(prev << 1) - 1] = next;
-		}
-	    }
-	    i__ = next;
-	    goto L100;
-	}
-	prev = i__;
-
-/*        Perform one bisection step */
-
-	negcnt = dlaneg_(n, &d__[1], &lld[1], &mid, pivmin, &r__);
-	if (negcnt <= i__ - 1) {
-	    work[k - 1] = mid;
-	} else {
-	    work[k] = mid;
-	}
-	i__ = next;
-L100:
-	;
-    }
-    ++iter;
-/*     do another loop if there are still unconverged intervals */
-/*     However, in the last iteration, all intervals are accepted */
-/*     since this is the best we can do. */
-    if (nint > 0 && iter <= maxitr) {
-	goto L80;
-    }
-
-
-/*     At this point, all the intervals have converged */
-    i__1 = *ilast;
-    for (i__ = *ifirst; i__ <= i__1; ++i__) {
-	k = i__ << 1;
-	ii = i__ - *offset;
-/*        All intervals marked by '0' have been refined. */
-	if (iwork[k - 1] == 0) {
-	    w[ii] = (work[k - 1] + work[k]) * .5;
-	    werr[ii] = work[k] - w[ii];
-	}
-/* L110: */
-    }
-
-    i__1 = *ilast;
-    for (i__ = *ifirst + 1; i__ <= i__1; ++i__) {
-	k = i__ << 1;
-	ii = i__ - *offset;
-/* Computing MAX */
-	d__1 = 0., d__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1];
-	wgap[ii - 1] = max(d__1,d__2);
-/* L111: */
-    }
-    return 0;
-
-/*     End of DLARRB */
-
-} /* dlarrb_ */

3rdparty/lapack/dlarrc.c

@@ -1,183 +0,0 @@
-/* dlarrc.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarrc_(char *jobt, integer *n, doublereal *vl, 
-	doublereal *vu, doublereal *d__, doublereal *e, doublereal *pivmin, 
-	integer *eigcnt, integer *lcnt, integer *rcnt, integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1;
-
-    /* Local variables */
-    integer i__;
-    doublereal sl, su, tmp, tmp2;
-    logical matt;
-    extern logical lsame_(char *, char *);
-    doublereal lpivot, rpivot;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  Find the number of eigenvalues of the symmetric tridiagonal matrix T */
-/*  that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T */
-/*  if JOBT = 'L'. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  JOBT    (input) CHARACTER*1 */
-/*          = 'T':  Compute Sturm count for matrix T. */
-/*          = 'L':  Compute Sturm count for matrix L D L^T. */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix. N > 0. */
-
-/*  VL      (input) DOUBLE PRECISION */
-/*  VU      (input) DOUBLE PRECISION */
-/*          The lower and upper bounds for the eigenvalues. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. */
-/*          JOBT = 'L': The N diagonal elements of the diagonal matrix D. */
-
-/*  E       (input) DOUBLE PRECISION array, dimension (N) */
-/*          JOBT = 'T': The N-1 offdiagonal elements of the matrix T. */
-/*          JOBT = 'L': The N-1 offdiagonal elements of the matrix L. */
-
-/*  PIVMIN  (input) DOUBLE PRECISION */
-/*          The minimum pivot in the Sturm sequence for T. */
-
-/*  EIGCNT  (output) INTEGER */
-/*          The number of eigenvalues of the symmetric tridiagonal matrix T */
-/*          that are in the interval (VL,VU] */
-
-/*  LCNT    (output) INTEGER */
-/*  RCNT    (output) INTEGER */
-/*          The left and right negcounts of the interval. */
-
-/*  INFO    (output) INTEGER */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --e;
-    --d__;
-
-    /* Function Body */
-    *info = 0;
-    *lcnt = 0;
-    *rcnt = 0;
-    *eigcnt = 0;
-    matt = lsame_(jobt, "T");
-    if (matt) {
-/*        Sturm sequence count on T */
-	lpivot = d__[1] - *vl;
-	rpivot = d__[1] - *vu;
-	if (lpivot <= 0.) {
-	    ++(*lcnt);
-	}
-	if (rpivot <= 0.) {
-	    ++(*rcnt);
-	}
-	i__1 = *n - 1;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-/* Computing 2nd power */
-	    d__1 = e[i__];
-	    tmp = d__1 * d__1;
-	    lpivot = d__[i__ + 1] - *vl - tmp / lpivot;
-	    rpivot = d__[i__ + 1] - *vu - tmp / rpivot;
-	    if (lpivot <= 0.) {
-		++(*lcnt);
-	    }
-	    if (rpivot <= 0.) {
-		++(*rcnt);
-	    }
-/* L10: */
-	}
-    } else {
-/*        Sturm sequence count on L D L^T */
-	sl = -(*vl);
-	su = -(*vu);
-	i__1 = *n - 1;
-	for (i__ = 1; i__ <= i__1; ++i__) {
-	    lpivot = d__[i__] + sl;
-	    rpivot = d__[i__] + su;
-	    if (lpivot <= 0.) {
-		++(*lcnt);
-	    }
-	    if (rpivot <= 0.) {
-		++(*rcnt);
-	    }
-	    tmp = e[i__] * d__[i__] * e[i__];
-
-	    tmp2 = tmp / lpivot;
-	    if (tmp2 == 0.) {
-		sl = tmp - *vl;
-	    } else {
-		sl = sl * tmp2 - *vl;
-	    }
-
-	    tmp2 = tmp / rpivot;
-	    if (tmp2 == 0.) {
-		su = tmp - *vu;
-	    } else {
-		su = su * tmp2 - *vu;
-	    }
-/* L20: */
-	}
-	lpivot = d__[*n] + sl;
-	rpivot = d__[*n] + su;
-	if (lpivot <= 0.) {
-	    ++(*lcnt);
-	}
-	if (rpivot <= 0.) {
-	    ++(*rcnt);
-	}
-    }
-    *eigcnt = *rcnt - *lcnt;
-    return 0;
-
-/*     end of DLARRC */
-
-} /* dlarrc_ */

3rdparty/lapack/dlarrd.c

@@ -1,793 +0,0 @@
-/* dlarrd.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c_n1 = -1;
-static integer c__3 = 3;
-static integer c__2 = 2;
-static integer c__0 = 0;
-
-/* Subroutine */ int dlarrd_(char *range, char *order, integer *n, doublereal 
-	*vl, doublereal *vu, integer *il, integer *iu, doublereal *gers, 
-	doublereal *reltol, doublereal *d__, doublereal *e, doublereal *e2, 
-	doublereal *pivmin, integer *nsplit, integer *isplit, integer *m, 
-	doublereal *w, doublereal *werr, doublereal *wl, doublereal *wu, 
-	integer *iblock, integer *indexw, doublereal *work, integer *iwork, 
-	integer *info)
-{
-    /* System generated locals */
-    integer i__1, i__2, i__3;
-    doublereal d__1, d__2;
-
-    /* Builtin functions */
-    double log(doublereal);
-
-    /* Local variables */
-    integer i__, j, ib, ie, je, nb;
-    doublereal gl;
-    integer im, in;
-    doublereal gu;
-    integer iw, jee;
-    doublereal eps;
-    integer nwl;
-    doublereal wlu, wul;
-    integer nwu;
-    doublereal tmp1, tmp2;
-    integer iend, jblk, ioff, iout, itmp1, itmp2, jdisc;
-    extern logical lsame_(char *, char *);
-    integer iinfo;
-    doublereal atoli;
-    integer iwoff, itmax;
-    doublereal wkill, rtoli, uflow, tnorm;
-    extern doublereal dlamch_(char *);
-    integer ibegin;
-    extern /* Subroutine */ int dlaebz_(integer *, integer *, integer *, 
-	    integer *, integer *, integer *, doublereal *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, integer *, 
-	     doublereal *, doublereal *, integer *, integer *, doublereal *, 
-	    integer *, integer *);
-    integer irange, idiscl, idumma[1];
-    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
-	    integer *, integer *);
-    integer idiscu;
-    logical ncnvrg, toofew;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2.1)                        -- */
-/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
-/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
-/*  -- April 2009                                                      -- */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLARRD computes the eigenvalues of a symmetric tridiagonal */
-/*  matrix T to suitable accuracy. This is an auxiliary code to be */
-/*  called from DSTEMR. */
-/*  The user may ask for all eigenvalues, all eigenvalues */
-/*  in the half-open interval (VL, VU], or the IL-th through IU-th */
-/*  eigenvalues. */
-
-/*  To avoid overflow, the matrix must be scaled so that its */
-/*  largest element is no greater than overflow**(1/2) * */
-/*  underflow**(1/4) in absolute value, and for greatest */
-/*  accuracy, it should not be much smaller than that. */
-
-/*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
-/*  Matrix", Report CS41, Computer Science Dept., Stanford */
-/*  University, July 21, 1966. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  RANGE   (input) CHARACTER */
-/*          = 'A': ("All")   all eigenvalues will be found. */
-/*          = 'V': ("Value") all eigenvalues in the half-open interval */
-/*                           (VL, VU] will be found. */
-/*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
-/*                           entire matrix) will be found. */
-
-/*  ORDER   (input) CHARACTER */
-/*          = 'B': ("By Block") the eigenvalues will be grouped by */
-/*                              split-off block (see IBLOCK, ISPLIT) and */
-/*                              ordered from smallest to largest within */
-/*                              the block. */
-/*          = 'E': ("Entire matrix") */
-/*                              the eigenvalues for the entire matrix */
-/*                              will be ordered from smallest to */
-/*                              largest. */
-
-/*  N       (input) INTEGER */
-/*          The order of the tridiagonal matrix T.  N >= 0. */
-
-/*  VL      (input) DOUBLE PRECISION */
-/*  VU      (input) DOUBLE PRECISION */
-/*          If RANGE='V', the lower and upper bounds of the interval to */
-/*          be searched for eigenvalues.  Eigenvalues less than or equal */
-/*          to VL, or greater than VU, will not be returned.  VL < VU. */
-/*          Not referenced if RANGE = 'A' or 'I'. */
-
-/*  IL      (input) INTEGER */
-/*  IU      (input) INTEGER */
-/*          If RANGE='I', the indices (in ascending order) of the */
-/*          smallest and largest eigenvalues to be returned. */
-/*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
-/*          Not referenced if RANGE = 'A' or 'V'. */
-
-/*  GERS    (input) DOUBLE PRECISION array, dimension (2*N) */
-/*          The N Gerschgorin intervals (the i-th Gerschgorin interval */
-/*          is (GERS(2*i-1), GERS(2*i)). */
-
-/*  RELTOL  (input) DOUBLE PRECISION */
-/*          The minimum relative width of an interval.  When an interval */
-/*          is narrower than RELTOL times the larger (in */
-/*          magnitude) endpoint, then it is considered to be */
-/*          sufficiently small, i.e., converged.  Note: this should */
-/*          always be at least radix*machine epsilon. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The n diagonal elements of the tridiagonal matrix T. */
-
-/*  E       (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The (n-1) off-diagonal elements of the tridiagonal matrix T. */
-
-/*  E2      (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */
-
-/*  PIVMIN  (input) DOUBLE PRECISION */
-/*          The minimum pivot allowed in the Sturm sequence for T. */
-
-/*  NSPLIT  (input) INTEGER */
-/*          The number of diagonal blocks in the matrix T. */
-/*          1 <= NSPLIT <= N. */
-
-/*  ISPLIT  (input) INTEGER array, dimension (N) */
-/*          The splitting points, at which T breaks up into submatrices. */
-/*          The first submatrix consists of rows/columns 1 to ISPLIT(1), */
-/*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
-/*          etc., and the NSPLIT-th consists of rows/columns */
-/*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
-/*          (Only the first NSPLIT elements will actually be used, but */
-/*          since the user cannot know a priori what value NSPLIT will */
-/*          have, N words must be reserved for ISPLIT.) */
-
-/*  M       (output) INTEGER */
-/*          The actual number of eigenvalues found. 0 <= M <= N. */
-/*          (See also the description of INFO=2,3.) */
-
-/*  W       (output) DOUBLE PRECISION array, dimension (N) */
-/*          On exit, the first M elements of W will contain the */
-/*          eigenvalue approximations. DLARRD computes an interval */
-/*          I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue */
-/*          approximation is given as the interval midpoint */
-/*          W(j)= ( a_j + b_j)/2. The corresponding error is bounded by */
-/*          WERR(j) = abs( a_j - b_j)/2 */
-
-/*  WERR    (output) DOUBLE PRECISION array, dimension (N) */
-/*          The error bound on the corresponding eigenvalue approximation */
-/*          in W. */
-
-/*  WL      (output) DOUBLE PRECISION */
-/*  WU      (output) DOUBLE PRECISION */
-/*          The interval (WL, WU] contains all the wanted eigenvalues. */
-/*          If RANGE='V', then WL=VL and WU=VU. */
-/*          If RANGE='A', then WL and WU are the global Gerschgorin bounds */
-/*                        on the spectrum. */
-/*          If RANGE='I', then WL and WU are computed by DLAEBZ from the */
-/*                        index range specified. */
-
-/*  IBLOCK  (output) INTEGER array, dimension (N) */
-/*          At each row/column j where E(j) is zero or small, the */
-/*          matrix T is considered to split into a block diagonal */
-/*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which */
-/*          block (from 1 to the number of blocks) the eigenvalue W(i) */
-/*          belongs.  (DLARRD may use the remaining N-M elements as */
-/*          workspace.) */
-
-/*  INDEXW  (output) INTEGER array, dimension (N) */
-/*          The indices of the eigenvalues within each block (submatrix); */
-/*          for example, INDEXW(i)= j and IBLOCK(i)=k imply that the */
-/*          i-th eigenvalue W(i) is the j-th eigenvalue in block k. */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N) */
-
-/*  IWORK   (workspace) INTEGER array, dimension (3*N) */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
-/*          > 0:  some or all of the eigenvalues failed to converge or */
-/*                were not computed: */
-/*                =1 or 3: Bisection failed to converge for some */
-/*                        eigenvalues; these eigenvalues are flagged by a */
-/*                        negative block number.  The effect is that the */
-/*                        eigenvalues may not be as accurate as the */
-/*                        absolute and relative tolerances.  This is */
-/*                        generally caused by unexpectedly inaccurate */
-/*                        arithmetic. */
-/*                =2 or 3: RANGE='I' only: Not all of the eigenvalues */
-/*                        IL:IU were found. */
-/*                        Effect: M < IU+1-IL */
-/*                        Cause:  non-monotonic arithmetic, causing the */
-/*                                Sturm sequence to be non-monotonic. */
-/*                        Cure:   recalculate, using RANGE='A', and pick */
-/*                                out eigenvalues IL:IU.  In some cases, */
-/*                                increasing the PARAMETER "FUDGE" may */
-/*                                make things work. */
-/*                = 4:    RANGE='I', and the Gershgorin interval */
-/*                        initially used was too small.  No eigenvalues */
-/*                        were computed. */
-/*                        Probable cause: your machine has sloppy */
-/*                                        floating-point arithmetic. */
-/*                        Cure: Increase the PARAMETER "FUDGE", */
-/*                              recompile, and try again. */
-
-/*  Internal Parameters */
-/*  =================== */
-
-/*  FUDGE   DOUBLE PRECISION, default = 2 */
-/*          A "fudge factor" to widen the Gershgorin intervals.  Ideally, */
-/*          a value of 1 should work, but on machines with sloppy */
-/*          arithmetic, this needs to be larger.  The default for */
-/*          publicly released versions should be large enough to handle */
-/*          the worst machine around.  Note that this has no effect */
-/*          on accuracy of the solution. */
-
-/*  Based on contributions by */
-/*     W. Kahan, University of California, Berkeley, USA */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Local Arrays .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --iwork;
-    --work;
-    --indexw;
-    --iblock;
-    --werr;
-    --w;
-    --isplit;
-    --e2;
-    --e;
-    --d__;
-    --gers;
-
-    /* Function Body */
-    *info = 0;
-
-/*     Decode RANGE */
-
-    if (lsame_(range, "A")) {
-	irange = 1;
-    } else if (lsame_(range, "V")) {
-	irange = 2;
-    } else if (lsame_(range, "I")) {
-	irange = 3;
-    } else {
-	irange = 0;
-    }
-
-/*     Check for Errors */
-
-    if (irange <= 0) {
-	*info = -1;
-    } else if (! (lsame_(order, "B") || lsame_(order, 
-	    "E"))) {
-	*info = -2;
-    } else if (*n < 0) {
-	*info = -3;
-    } else if (irange == 2) {
-	if (*vl >= *vu) {
-	    *info = -5;
-	}
-    } else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
-	*info = -6;
-    } else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
-	*info = -7;
-    }
-
-    if (*info != 0) {
-	return 0;
-    }
-/*     Initialize error flags */
-    *info = 0;
-    ncnvrg = FALSE_;
-    toofew = FALSE_;
-/*     Quick return if possible */
-    *m = 0;
-    if (*n == 0) {
-	return 0;
-    }
-/*     Simplification: */
-    if (irange == 3 && *il == 1 && *iu == *n) {
-	irange = 1;
-    }
-/*     Get machine constants */
-    eps = dlamch_("P");
-    uflow = dlamch_("U");
-/*     Special Case when N=1 */
-/*     Treat case of 1x1 matrix for quick return */
-    if (*n == 1) {
-	if (irange == 1 || irange == 2 && d__[1] > *vl && d__[1] <= *vu || 
-		irange == 3 && *il == 1 && *iu == 1) {
-	    *m = 1;
-	    w[1] = d__[1];
-/*           The computation error of the eigenvalue is zero */
-	    werr[1] = 0.;
-	    iblock[1] = 1;
-	    indexw[1] = 1;
-	}
-	return 0;
-    }
-/*     NB is the minimum vector length for vector bisection, or 0 */
-/*     if only scalar is to be done. */
-    nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1);
-    if (nb <= 1) {
-	nb = 0;
-    }
-/*     Find global spectral radius */
-    gl = d__[1];
-    gu = d__[1];
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-/* Computing MIN */
-	d__1 = gl, d__2 = gers[(i__ << 1) - 1];
-	gl = min(d__1,d__2);
-/* Computing MAX */
-	d__1 = gu, d__2 = gers[i__ * 2];
-	gu = max(d__1,d__2);
-/* L5: */
-    }
-/*     Compute global Gerschgorin bounds and spectral diameter */
-/* Computing MAX */
-    d__1 = abs(gl), d__2 = abs(gu);
-    tnorm = max(d__1,d__2);
-    gl = gl - tnorm * 2. * eps * *n - *pivmin * 4.;
-    gu = gu + tnorm * 2. * eps * *n + *pivmin * 4.;
-/*     [JAN/28/2009] remove the line below since SPDIAM variable not use */
-/*     SPDIAM = GU - GL */
-/*     Input arguments for DLAEBZ: */
-/*     The relative tolerance.  An interval (a,b] lies within */
-/*     "relative tolerance" if  b-a < RELTOL*max(|a|,|b|), */
-    rtoli = *reltol;
-/*     Set the absolute tolerance for interval convergence to zero to force */
-/*     interval convergence based on relative size of the interval. */
-/*     This is dangerous because intervals might not converge when RELTOL is */
-/*     small. But at least a very small number should be selected so that for */
-/*     strongly graded matrices, the code can get relatively accurate */
-/*     eigenvalues. */
-    atoli = uflow * 4. + *pivmin * 4.;
-    if (irange == 3) {
-/*        RANGE='I': Compute an interval containing eigenvalues */
-/*        IL through IU. The initial interval [GL,GU] from the global */
-/*        Gerschgorin bounds GL and GU is refined by DLAEBZ. */
-	itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.)) + 
-		2;
-	work[*n + 1] = gl;
-	work[*n + 2] = gl;
-	work[*n + 3] = gu;
-	work[*n + 4] = gu;
-	work[*n + 5] = gl;
-	work[*n + 6] = gu;
-	iwork[1] = -1;
-	iwork[2] = -1;
-	iwork[3] = *n + 1;
-	iwork[4] = *n + 1;
-	iwork[5] = *il - 1;
-	iwork[6] = *iu;
-
-	dlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, pivmin, &
-		d__[1], &e[1], &e2[1], &iwork[5], &work[*n + 1], &work[*n + 5]
-, &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
-	if (iinfo != 0) {
-	    *info = iinfo;
-	    return 0;
-	}
-/*        On exit, output intervals may not be ordered by ascending negcount */
-	if (iwork[6] == *iu) {
-	    *wl = work[*n + 1];
-	    wlu = work[*n + 3];
-	    nwl = iwork[1];
-	    *wu = work[*n + 4];
-	    wul = work[*n + 2];
-	    nwu = iwork[4];
-	} else {
-	    *wl = work[*n + 2];
-	    wlu = work[*n + 4];
-	    nwl = iwork[2];
-	    *wu = work[*n + 3];
-	    wul = work[*n + 1];
-	    nwu = iwork[3];
-	}
-/*        On exit, the interval [WL, WLU] contains a value with negcount NWL, */
-/*        and [WUL, WU] contains a value with negcount NWU. */
-	if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
-	    *info = 4;
-	    return 0;
-	}
-    } else if (irange == 2) {
-	*wl = *vl;
-	*wu = *vu;
-    } else if (irange == 1) {
-	*wl = gl;
-	*wu = gu;
-    }
-/*     Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. */
-/*     NWL accumulates the number of eigenvalues .le. WL, */
-/*     NWU accumulates the number of eigenvalues .le. WU */
-    *m = 0;
-    iend = 0;
-    *info = 0;
-    nwl = 0;
-    nwu = 0;
-
-    i__1 = *nsplit;
-    for (jblk = 1; jblk <= i__1; ++jblk) {
-	ioff = iend;
-	ibegin = ioff + 1;
-	iend = isplit[jblk];
-	in = iend - ioff;
-
-	if (in == 1) {
-/*           1x1 block */
-	    if (*wl >= d__[ibegin] - *pivmin) {
-		++nwl;
-	    }
-	    if (*wu >= d__[ibegin] - *pivmin) {
-		++nwu;
-	    }
-	    if (irange == 1 || *wl < d__[ibegin] - *pivmin && *wu >= d__[
-		    ibegin] - *pivmin) {
-		++(*m);
-		w[*m] = d__[ibegin];
-		werr[*m] = 0.;
-/*              The gap for a single block doesn't matter for the later */
-/*              algorithm and is assigned an arbitrary large value */
-		iblock[*m] = jblk;
-		indexw[*m] = 1;
-	    }
-/*        Disabled 2x2 case because of a failure on the following matrix */
-/*        RANGE = 'I', IL = IU = 4 */
-/*          Original Tridiagonal, d = [ */
-/*           -0.150102010615740E+00 */
-/*           -0.849897989384260E+00 */
-/*           -0.128208148052635E-15 */
-/*            0.128257718286320E-15 */
-/*          ]; */
-/*          e = [ */
-/*           -0.357171383266986E+00 */
-/*           -0.180411241501588E-15 */
-/*           -0.175152352710251E-15 */
-/*          ]; */
-
-/*         ELSE IF( IN.EQ.2 ) THEN */
-/* *           2x2 block */
-/*            DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) */
-/*            TMP1 = HALF*(D(IBEGIN)+D(IEND)) */
-/*            L1 = TMP1 - DISC */
-/*            IF( WL.GE. L1-PIVMIN ) */
-/*     $         NWL = NWL + 1 */
-/*            IF( WU.GE. L1-PIVMIN ) */
-/*     $         NWU = NWU + 1 */
-/*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. */
-/*     $          L1-PIVMIN ) ) THEN */
-/*               M = M + 1 */
-/*               W( M ) = L1 */
-/* *              The uncertainty of eigenvalues of a 2x2 matrix is very small */
-/*               WERR( M ) = EPS * ABS( W( M ) ) * TWO */
-/*               IBLOCK( M ) = JBLK */
-/*               INDEXW( M ) = 1 */
-/*            ENDIF */
-/*            L2 = TMP1 + DISC */
-/*            IF( WL.GE. L2-PIVMIN ) */
-/*     $         NWL = NWL + 1 */
-/*            IF( WU.GE. L2-PIVMIN ) */
-/*     $         NWU = NWU + 1 */
-/*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. */
-/*     $          L2-PIVMIN ) ) THEN */
-/*               M = M + 1 */
-/*               W( M ) = L2 */
-/* *              The uncertainty of eigenvalues of a 2x2 matrix is very small */
-/*               WERR( M ) = EPS * ABS( W( M ) ) * TWO */
-/*               IBLOCK( M ) = JBLK */
-/*               INDEXW( M ) = 2 */
-/*            ENDIF */
-	} else {
-/*           General Case - block of size IN >= 2 */
-/*           Compute local Gerschgorin interval and use it as the initial */
-/*           interval for DLAEBZ */
-	    gu = d__[ibegin];
-	    gl = d__[ibegin];
-	    tmp1 = 0.;
-	    i__2 = iend;
-	    for (j = ibegin; j <= i__2; ++j) {
-/* Computing MIN */
-		d__1 = gl, d__2 = gers[(j << 1) - 1];
-		gl = min(d__1,d__2);
-/* Computing MAX */
-		d__1 = gu, d__2 = gers[j * 2];
-		gu = max(d__1,d__2);
-/* L40: */
-	    }
-/*           [JAN/28/2009] */
-/*           change SPDIAM by TNORM in lines 2 and 3 thereafter */
-/*           line 1: remove computation of SPDIAM (not useful anymore) */
-/*           SPDIAM = GU - GL */
-/*           GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN */
-/*           GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN */
-	    gl = gl - tnorm * 2. * eps * in - *pivmin * 2.;
-	    gu = gu + tnorm * 2. * eps * in + *pivmin * 2.;
-
-	    if (irange > 1) {
-		if (gu < *wl) {
-/*                 the local block contains none of the wanted eigenvalues */
-		    nwl += in;
-		    nwu += in;
-		    goto L70;
-		}
-/*              refine search interval if possible, only range (WL,WU] matters */
-		gl = max(gl,*wl);
-		gu = min(gu,*wu);
-		if (gl >= gu) {
-		    goto L70;
-		}
-	    }
-/*           Find negcount of initial interval boundaries GL and GU */
-	    work[*n + 1] = gl;
-	    work[*n + in + 1] = gu;
-	    dlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, 
-		    pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, &
-		    work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
-		    w[*m + 1], &iblock[*m + 1], &iinfo);
-	    if (iinfo != 0) {
-		*info = iinfo;
-		return 0;
-	    }
-
-	    nwl += iwork[1];
-	    nwu += iwork[in + 1];
-	    iwoff = *m - iwork[1];
-/*           Compute Eigenvalues */
-	    itmax = (integer) ((log(gu - gl + *pivmin) - log(*pivmin)) / log(
-		    2.)) + 2;
-	    dlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, 
-		    pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, &
-		    work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], 
-		     &w[*m + 1], &iblock[*m + 1], &iinfo);
-	    if (iinfo != 0) {
-		*info = iinfo;
-		return 0;
-	    }
-
-/*           Copy eigenvalues into W and IBLOCK */
-/*           Use -JBLK for block number for unconverged eigenvalues. */
-/*           Loop over the number of output intervals from DLAEBZ */
-	    i__2 = iout;
-	    for (j = 1; j <= i__2; ++j) {
-/*              eigenvalue approximation is middle point of interval */
-		tmp1 = (work[j + *n] + work[j + in + *n]) * .5;
-/*              semi length of error interval */
-		tmp2 = (d__1 = work[j + *n] - work[j + in + *n], abs(d__1)) * 
-			.5;
-		if (j > iout - iinfo) {
-/*                 Flag non-convergence. */
-		    ncnvrg = TRUE_;
-		    ib = -jblk;
-		} else {
-		    ib = jblk;
-		}
-		i__3 = iwork[j + in] + iwoff;
-		for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
-		    w[je] = tmp1;
-		    werr[je] = tmp2;
-		    indexw[je] = je - iwoff;
-		    iblock[je] = ib;
-/* L50: */
-		}
-/* L60: */
-	    }
-
-	    *m += im;
-	}
-L70:
-	;
-    }
-/*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */
-/*     If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
-    if (irange == 3) {
-	idiscl = *il - 1 - nwl;
-	idiscu = nwu - *iu;
-
-	if (idiscl > 0) {
-	    im = 0;
-	    i__1 = *m;
-	    for (je = 1; je <= i__1; ++je) {
-/*              Remove some of the smallest eigenvalues from the left so that */
-/*              at the end IDISCL =0. Move all eigenvalues up to the left. */
-		if (w[je] <= wlu && idiscl > 0) {
-		    --idiscl;
-		} else {
-		    ++im;
-		    w[im] = w[je];
-		    werr[im] = werr[je];
-		    indexw[im] = indexw[je];
-		    iblock[im] = iblock[je];
-		}
-/* L80: */
-	    }
-	    *m = im;
-	}
-	if (idiscu > 0) {
-/*           Remove some of the largest eigenvalues from the right so that */
-/*           at the end IDISCU =0. Move all eigenvalues up to the left. */
-	    im = *m + 1;
-	    for (je = *m; je >= 1; --je) {
-		if (w[je] >= wul && idiscu > 0) {
-		    --idiscu;
-		} else {
-		    --im;
-		    w[im] = w[je];
-		    werr[im] = werr[je];
-		    indexw[im] = indexw[je];
-		    iblock[im] = iblock[je];
-		}
-/* L81: */
-	    }
-	    jee = 0;
-	    i__1 = *m;
-	    for (je = im; je <= i__1; ++je) {
-		++jee;
-		w[jee] = w[je];
-		werr[jee] = werr[je];
-		indexw[jee] = indexw[je];
-		iblock[jee] = iblock[je];
-/* L82: */
-	    }
-	    *m = *m - im + 1;
-	}
-	if (idiscl > 0 || idiscu > 0) {
-/*           Code to deal with effects of bad arithmetic. (If N(w) is */
-/*           monotone non-decreasing, this should never happen.) */
-/*           Some low eigenvalues to be discarded are not in (WL,WLU], */
-/*           or high eigenvalues to be discarded are not in (WUL,WU] */
-/*           so just kill off the smallest IDISCL/largest IDISCU */
-/*           eigenvalues, by marking the corresponding IBLOCK = 0 */
-	    if (idiscl > 0) {
-		wkill = *wu;
-		i__1 = idiscl;
-		for (jdisc = 1; jdisc <= i__1; ++jdisc) {
-		    iw = 0;
-		    i__2 = *m;
-		    for (je = 1; je <= i__2; ++je) {
-			if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
-			    iw = je;
-			    wkill = w[je];
-			}
-/* L90: */
-		    }
-		    iblock[iw] = 0;
-/* L100: */
-		}
-	    }
-	    if (idiscu > 0) {
-		wkill = *wl;
-		i__1 = idiscu;
-		for (jdisc = 1; jdisc <= i__1; ++jdisc) {
-		    iw = 0;
-		    i__2 = *m;
-		    for (je = 1; je <= i__2; ++je) {
-			if (iblock[je] != 0 && (w[je] >= wkill || iw == 0)) {
-			    iw = je;
-			    wkill = w[je];
-			}
-/* L110: */
-		    }
-		    iblock[iw] = 0;
-/* L120: */
-		}
-	    }
-/*           Now erase all eigenvalues with IBLOCK set to zero */
-	    im = 0;
-	    i__1 = *m;
-	    for (je = 1; je <= i__1; ++je) {
-		if (iblock[je] != 0) {
-		    ++im;
-		    w[im] = w[je];
-		    werr[im] = werr[je];
-		    indexw[im] = indexw[je];
-		    iblock[im] = iblock[je];
-		}
-/* L130: */
-	    }
-	    *m = im;
-	}
-	if (idiscl < 0 || idiscu < 0) {
-	    toofew = TRUE_;
-	}
-    }
-
-    if (irange == 1 && *m != *n || irange == 3 && *m != *iu - *il + 1) {
-	toofew = TRUE_;
-    }
-/*     If ORDER='B', do nothing the eigenvalues are already sorted by */
-/*        block. */
-/*     If ORDER='E', sort the eigenvalues from smallest to largest */
-    if (lsame_(order, "E") && *nsplit > 1) {
-	i__1 = *m - 1;
-	for (je = 1; je <= i__1; ++je) {
-	    ie = 0;
-	    tmp1 = w[je];
-	    i__2 = *m;
-	    for (j = je + 1; j <= i__2; ++j) {
-		if (w[j] < tmp1) {
-		    ie = j;
-		    tmp1 = w[j];
-		}
-/* L140: */
-	    }
-	    if (ie != 0) {
-		tmp2 = werr[ie];
-		itmp1 = iblock[ie];
-		itmp2 = indexw[ie];
-		w[ie] = w[je];
-		werr[ie] = werr[je];
-		iblock[ie] = iblock[je];
-		indexw[ie] = indexw[je];
-		w[je] = tmp1;
-		werr[je] = tmp2;
-		iblock[je] = itmp1;
-		indexw[je] = itmp2;
-	    }
-/* L150: */
-	}
-    }
-
-    *info = 0;
-    if (ncnvrg) {
-	++(*info);
-    }
-    if (toofew) {
-	*info += 2;
-    }
-    return 0;
-
-/*     End of DLARRD */
-
-} /* dlarrd_ */

3rdparty/lapack/dlarre.c

@@ -1,861 +0,0 @@
-/* dlarre.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c__2 = 2;
-
-/* Subroutine */ int dlarre_(char *range, integer *n, doublereal *vl, 
-	doublereal *vu, integer *il, integer *iu, doublereal *d__, doublereal 
-	*e, doublereal *e2, doublereal *rtol1, doublereal *rtol2, doublereal *
-	spltol, integer *nsplit, integer *isplit, integer *m, doublereal *w, 
-	doublereal *werr, doublereal *wgap, integer *iblock, integer *indexw, 
-	doublereal *gers, doublereal *pivmin, doublereal *work, integer *
-	iwork, integer *info)
-{
-    /* System generated locals */
-    integer i__1, i__2;
-    doublereal d__1, d__2, d__3;
-
-    /* Builtin functions */
-    double sqrt(doublereal), log(doublereal);
-
-    /* Local variables */
-    integer i__, j;
-    doublereal s1, s2;
-    integer mb;
-    doublereal gl;
-    integer in, mm;
-    doublereal gu;
-    integer cnt;
-    doublereal eps, tau, tmp, rtl;
-    integer cnt1, cnt2;
-    doublereal tmp1, eabs;
-    integer iend, jblk;
-    doublereal eold;
-    integer indl;
-    doublereal dmax__, emax;
-    integer wend, idum, indu;
-    doublereal rtol;
-    integer iseed[4];
-    doublereal avgap, sigma;
-    extern logical lsame_(char *, char *);
-    integer iinfo;
-    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *);
-    logical norep;
-    extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *);
-    extern doublereal dlamch_(char *);
-    integer ibegin;
-    logical forceb;
-    integer irange;
-    doublereal sgndef;
-    extern /* Subroutine */ int dlarra_(integer *, doublereal *, doublereal *, 
-	     doublereal *, doublereal *, doublereal *, integer *, integer *, 
-	    integer *), dlarrb_(integer *, doublereal *, doublereal *, 
-	    integer *, integer *, doublereal *, doublereal *, integer *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, integer *, 
-	     doublereal *, doublereal *, integer *, integer *), dlarrc_(char *
-, integer *, doublereal *, doublereal *, doublereal *, doublereal 
-	    *, doublereal *, integer *, integer *, integer *, integer *);
-    integer wbegin;
-    extern /* Subroutine */ int dlarrd_(char *, char *, integer *, doublereal 
-	    *, doublereal *, integer *, integer *, doublereal *, doublereal *, 
-	     doublereal *, doublereal *, doublereal *, doublereal *, integer *
-, integer *, integer *, doublereal *, doublereal *, doublereal *, 
-	    doublereal *, integer *, integer *, doublereal *, integer *, 
-	    integer *);
-    doublereal safmin, spdiam;
-    extern /* Subroutine */ int dlarrk_(integer *, integer *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *, doublereal *, 
-	    doublereal *, doublereal *, doublereal *, integer *);
-    logical usedqd;
-    doublereal clwdth, isleft;
-    extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *, 
-	    doublereal *);
-    doublereal isrght, bsrtol, dpivot;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  To find the desired eigenvalues of a given real symmetric */
-/*  tridiagonal matrix T, DLARRE sets any "small" off-diagonal */
-/*  elements to zero, and for each unreduced block T_i, it finds */
-/*  (a) a suitable shift at one end of the block's spectrum, */
-/*  (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */
-/*  (c) eigenvalues of each L_i D_i L_i^T. */
-/*  The representations and eigenvalues found are then used by */
-/*  DSTEMR to compute the eigenvectors of T. */
-/*  The accuracy varies depending on whether bisection is used to */
-/*  find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to */
-/*  conpute all and then discard any unwanted one. */
-/*  As an added benefit, DLARRE also outputs the n */
-/*  Gerschgorin intervals for the matrices L_i D_i L_i^T. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  RANGE   (input) CHARACTER */
-/*          = 'A': ("All")   all eigenvalues will be found. */
-/*          = 'V': ("Value") all eigenvalues in the half-open interval */
-/*                           (VL, VU] will be found. */
-/*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
-/*                           entire matrix) will be found. */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix. N > 0. */
-
-/*  VL      (input/output) DOUBLE PRECISION */
-/*  VU      (input/output) DOUBLE PRECISION */
-/*          If RANGE='V', the lower and upper bounds for the eigenvalues. */
-/*          Eigenvalues less than or equal to VL, or greater than VU, */
-/*          will not be returned.  VL < VU. */
-/*          If RANGE='I' or ='A', DLARRE computes bounds on the desired */
-/*          part of the spectrum. */
-
-/*  IL      (input) INTEGER */
-/*  IU      (input) INTEGER */
-/*          If RANGE='I', the indices (in ascending order) of the */
-/*          smallest and largest eigenvalues to be returned. */
-/*          1 <= IL <= IU <= N. */
-
-/*  D       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the N diagonal elements of the tridiagonal */
-/*          matrix T. */
-/*          On exit, the N diagonal elements of the diagonal */
-/*          matrices D_i. */
-
-/*  E       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the first (N-1) entries contain the subdiagonal */
-/*          elements of the tridiagonal matrix T; E(N) need not be set. */
-/*          On exit, E contains the subdiagonal elements of the unit */
-/*          bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */
-/*          1 <= I <= NSPLIT, contain the base points sigma_i on output. */
-
-/*  E2      (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the first (N-1) entries contain the SQUARES of the */
-/*          subdiagonal elements of the tridiagonal matrix T; */
-/*          E2(N) need not be set. */
-/*          On exit, the entries E2( ISPLIT( I ) ), */
-/*          1 <= I <= NSPLIT, have been set to zero */
-
-/*  RTOL1   (input) DOUBLE PRECISION */
-/*  RTOL2   (input) DOUBLE PRECISION */
-/*           Parameters for bisection. */
-/*           An interval [LEFT,RIGHT] has converged if */
-/*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
-
-/*  SPLTOL (input) DOUBLE PRECISION */
-/*          The threshold for splitting. */
-
-/*  NSPLIT  (output) INTEGER */
-/*          The number of blocks T splits into. 1 <= NSPLIT <= N. */
-
-/*  ISPLIT  (output) INTEGER array, dimension (N) */
-/*          The splitting points, at which T breaks up into blocks. */
-/*          The first block consists of rows/columns 1 to ISPLIT(1), */
-/*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
-/*          etc., and the NSPLIT-th consists of rows/columns */
-/*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
-
-/*  M       (output) INTEGER */
-/*          The total number of eigenvalues (of all L_i D_i L_i^T) */
-/*          found. */
-
-/*  W       (output) DOUBLE PRECISION array, dimension (N) */
-/*          The first M elements contain the eigenvalues. The */
-/*          eigenvalues of each of the blocks, L_i D_i L_i^T, are */
-/*          sorted in ascending order ( DLARRE may use the */
-/*          remaining N-M elements as workspace). */
-
-/*  WERR    (output) DOUBLE PRECISION array, dimension (N) */
-/*          The error bound on the corresponding eigenvalue in W. */
-
-/*  WGAP    (output) DOUBLE PRECISION array, dimension (N) */
-/*          The separation from the right neighbor eigenvalue in W. */
-/*          The gap is only with respect to the eigenvalues of the same block */
-/*          as each block has its own representation tree. */
-/*          Exception: at the right end of a block we store the left gap */
-
-/*  IBLOCK  (output) INTEGER array, dimension (N) */
-/*          The indices of the blocks (submatrices) associated with the */
-/*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
-/*          W(i) belongs to the first block from the top, =2 if W(i) */
-/*          belongs to the second block, etc. */
-
-/*  INDEXW  (output) INTEGER array, dimension (N) */
-/*          The indices of the eigenvalues within each block (submatrix); */
-/*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
-/*          i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */
-
-/*  GERS    (output) DOUBLE PRECISION array, dimension (2*N) */
-/*          The N Gerschgorin intervals (the i-th Gerschgorin interval */
-/*          is (GERS(2*i-1), GERS(2*i)). */
-
-/*  PIVMIN  (output) DOUBLE PRECISION */
-/*          The minimum pivot in the Sturm sequence for T. */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N) */
-/*          Workspace. */
-
-/*  IWORK   (workspace) INTEGER array, dimension (5*N) */
-/*          Workspace. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:  successful exit */
-/*          > 0:  A problem occured in DLARRE. */
-/*          < 0:  One of the called subroutines signaled an internal problem. */
-/*                Needs inspection of the corresponding parameter IINFO */
-/*                for further information. */
-
-/*          =-1:  Problem in DLARRD. */
-/*          = 2:  No base representation could be found in MAXTRY iterations. */
-/*                Increasing MAXTRY and recompilation might be a remedy. */
-/*          =-3:  Problem in DLARRB when computing the refined root */
-/*                representation for DLASQ2. */
-/*          =-4:  Problem in DLARRB when preforming bisection on the */
-/*                desired part of the spectrum. */
-/*          =-5:  Problem in DLASQ2. */
-/*          =-6:  Problem in DLASQ2. */
-
-/*  Further Details */
-/*  The base representations are required to suffer very little */
-/*  element growth and consequently define all their eigenvalues to */
-/*  high relative accuracy. */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. Local Arrays .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --iwork;
-    --work;
-    --gers;
-    --indexw;
-    --iblock;
-    --wgap;
-    --werr;
-    --w;
-    --isplit;
-    --e2;
-    --e;
-    --d__;
-
-    /* Function Body */
-    *info = 0;
-
-/*     Decode RANGE */
-
-    if (lsame_(range, "A")) {
-	irange = 1;
-    } else if (lsame_(range, "V")) {
-	irange = 3;
-    } else if (lsame_(range, "I")) {
-	irange = 2;
-    }
-    *m = 0;
-/*     Get machine constants */
-    safmin = dlamch_("S");
-    eps = dlamch_("P");
-/*     Set parameters */
-    rtl = sqrt(eps);
-    bsrtol = sqrt(eps);
-/*     Treat case of 1x1 matrix for quick return */
-    if (*n == 1) {
-	if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu || 
-		irange == 2 && *il == 1 && *iu == 1) {
-	    *m = 1;
-	    w[1] = d__[1];
-/*           The computation error of the eigenvalue is zero */
-	    werr[1] = 0.;
-	    wgap[1] = 0.;
-	    iblock[1] = 1;
-	    indexw[1] = 1;
-	    gers[1] = d__[1];
-	    gers[2] = d__[1];
-	}
-/*        store the shift for the initial RRR, which is zero in this case */
-	e[1] = 0.;
-	return 0;
-    }
-/*     General case: tridiagonal matrix of order > 1 */
-
-/*     Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */
-/*     Compute maximum off-diagonal entry and pivmin. */
-    gl = d__[1];
-    gu = d__[1];
-    eold = 0.;
-    emax = 0.;
-    e[*n] = 0.;
-    i__1 = *n;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	werr[i__] = 0.;
-	wgap[i__] = 0.;
-	eabs = (d__1 = e[i__], abs(d__1));
-	if (eabs >= emax) {
-	    emax = eabs;
-	}
-	tmp1 = eabs + eold;
-	gers[(i__ << 1) - 1] = d__[i__] - tmp1;
-/* Computing MIN */
-	d__1 = gl, d__2 = gers[(i__ << 1) - 1];
-	gl = min(d__1,d__2);
-	gers[i__ * 2] = d__[i__] + tmp1;
-/* Computing MAX */
-	d__1 = gu, d__2 = gers[i__ * 2];
-	gu = max(d__1,d__2);
-	eold = eabs;
-/* L5: */
-    }
-/*     The minimum pivot allowed in the Sturm sequence for T */
-/* Computing MAX */
-/* Computing 2nd power */
-    d__3 = emax;
-    d__1 = 1., d__2 = d__3 * d__3;
-    *pivmin = safmin * max(d__1,d__2);
-/*     Compute spectral diameter. The Gerschgorin bounds give an */
-/*     estimate that is wrong by at most a factor of SQRT(2) */
-    spdiam = gu - gl;
-/*     Compute splitting points */
-    dlarra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], &
-	    iinfo);
-/*     Can force use of bisection instead of faster DQDS. */
-/*     Option left in the code for future multisection work. */
-    forceb = FALSE_;
-/*     Initialize USEDQD, DQDS should be used for ALLRNG unless someone */
-/*     explicitly wants bisection. */
-    usedqd = irange == 1 && ! forceb;
-    if (irange == 1 && ! forceb) {
-/*        Set interval [VL,VU] that contains all eigenvalues */
-	*vl = gl;
-	*vu = gu;
-    } else {
-/*        We call DLARRD to find crude approximations to the eigenvalues */
-/*        in the desired range. In case IRANGE = INDRNG, we also obtain the */
-/*        interval (VL,VU] that contains all the wanted eigenvalues. */
-/*        An interval [LEFT,RIGHT] has converged if */
-/*        RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */
-/*        DLARRD needs a WORK of size 4*N, IWORK of size 3*N */
-	dlarrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[
-		1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1], 
-		vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo);
-	if (iinfo != 0) {
-	    *info = -1;
-	    return 0;
-	}
-/*        Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */
-	i__1 = *n;
-	for (i__ = mm + 1; i__ <= i__1; ++i__) {
-	    w[i__] = 0.;
-	    werr[i__] = 0.;
-	    iblock[i__] = 0;
-	    indexw[i__] = 0;
-/* L14: */
-	}
-    }
-/* ** */
-/*     Loop over unreduced blocks */
-    ibegin = 1;
-    wbegin = 1;
-    i__1 = *nsplit;
-    for (jblk = 1; jblk <= i__1; ++jblk) {
-	iend = isplit[jblk];
-	in = iend - ibegin + 1;
-/*        1 X 1 block */
-	if (in == 1) {
-	    if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin]
-		     <= *vu || irange == 2 && iblock[wbegin] == jblk) {
-		++(*m);
-		w[*m] = d__[ibegin];
-		werr[*m] = 0.;
-/*              The gap for a single block doesn't matter for the later */
-/*              algorithm and is assigned an arbitrary large value */
-		wgap[*m] = 0.;
-		iblock[*m] = jblk;
-		indexw[*m] = 1;
-		++wbegin;
-	    }
-/*           E( IEND ) holds the shift for the initial RRR */
-	    e[iend] = 0.;
-	    ibegin = iend + 1;
-	    goto L170;
-	}
-
-/*        Blocks of size larger than 1x1 */
-
-/*        E( IEND ) will hold the shift for the initial RRR, for now set it =0 */
-	e[iend] = 0.;
-
-/*        Find local outer bounds GL,GU for the block */
-	gl = d__[ibegin];
-	gu = d__[ibegin];
-	i__2 = iend;
-	for (i__ = ibegin; i__ <= i__2; ++i__) {
-/* Computing MIN */
-	    d__1 = gers[(i__ << 1) - 1];
-	    gl = min(d__1,gl);
-/* Computing MAX */
-	    d__1 = gers[i__ * 2];
-	    gu = max(d__1,gu);
-/* L15: */
-	}
-	spdiam = gu - gl;
-	if (! (irange == 1 && ! forceb)) {
-/*           Count the number of eigenvalues in the current block. */
-	    mb = 0;
-	    i__2 = mm;
-	    for (i__ = wbegin; i__ <= i__2; ++i__) {
-		if (iblock[i__] == jblk) {
-		    ++mb;
-		} else {
-		    goto L21;
-		}
-/* L20: */
-	    }
-L21:
-	    if (mb == 0) {
-/*              No eigenvalue in the current block lies in the desired range */
-/*              E( IEND ) holds the shift for the initial RRR */
-		e[iend] = 0.;
-		ibegin = iend + 1;
-		goto L170;
-	    } else {
-/*              Decide whether dqds or bisection is more efficient */
-		usedqd = (doublereal) mb > in * .5 && ! forceb;
-		wend = wbegin + mb - 1;
-/*              Calculate gaps for the current block */
-/*              In later stages, when representations for individual */
-/*              eigenvalues are different, we use SIGMA = E( IEND ). */
-		sigma = 0.;
-		i__2 = wend - 1;
-		for (i__ = wbegin; i__ <= i__2; ++i__) {
-/* Computing MAX */
-		    d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + 
-			    werr[i__]);
-		    wgap[i__] = max(d__1,d__2);
-/* L30: */
-		}
-/* Computing MAX */
-		d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]);
-		wgap[wend] = max(d__1,d__2);
-/*              Find local index of the first and last desired evalue. */
-		indl = indexw[wbegin];
-		indu = indexw[wend];
-	    }
-	}
-	if (irange == 1 && ! forceb || usedqd) {
-/*           Case of DQDS */
-/*           Find approximations to the extremal eigenvalues of the block */
-	    dlarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
-		    rtl, &tmp, &tmp1, &iinfo);
-	    if (iinfo != 0) {
-		*info = -1;
-		return 0;
-	    }
-/* Computing MAX */
-	    d__2 = gl, d__3 = tmp - tmp1 - eps * 100. * (d__1 = tmp - tmp1, 
-		    abs(d__1));
-	    isleft = max(d__2,d__3);
-	    dlarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
-		    rtl, &tmp, &tmp1, &iinfo);
-	    if (iinfo != 0) {
-		*info = -1;
-		return 0;
-	    }
-/* Computing MIN */
-	    d__2 = gu, d__3 = tmp + tmp1 + eps * 100. * (d__1 = tmp + tmp1, 
-		    abs(d__1));
-	    isrght = min(d__2,d__3);
-/*           Improve the estimate of the spectral diameter */
-	    spdiam = isrght - isleft;
-	} else {
-/*           Case of bisection */
-/*           Find approximations to the wanted extremal eigenvalues */
-/* Computing MAX */
-	    d__2 = gl, d__3 = w[wbegin] - werr[wbegin] - eps * 100. * (d__1 = 
-		    w[wbegin] - werr[wbegin], abs(d__1));
-	    isleft = max(d__2,d__3);
-/* Computing MIN */
-	    d__2 = gu, d__3 = w[wend] + werr[wend] + eps * 100. * (d__1 = w[
-		    wend] + werr[wend], abs(d__1));
-	    isrght = min(d__2,d__3);
-	}
-/*        Decide whether the base representation for the current block */
-/*        L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */
-/*        should be on the left or the right end of the current block. */
-/*        The strategy is to shift to the end which is "more populated" */
-/*        Furthermore, decide whether to use DQDS for the computation of */
-/*        the eigenvalue approximations at the end of DLARRE or bisection. */
-/*        dqds is chosen if all eigenvalues are desired or the number of */
-/*        eigenvalues to be computed is large compared to the blocksize. */
-	if (irange == 1 && ! forceb) {
-/*           If all the eigenvalues have to be computed, we use dqd */
-	    usedqd = TRUE_;
-/*           INDL is the local index of the first eigenvalue to compute */
-	    indl = 1;
-	    indu = in;
-/*           MB =  number of eigenvalues to compute */
-	    mb = in;
-	    wend = wbegin + mb - 1;
-/*           Define 1/4 and 3/4 points of the spectrum */
-	    s1 = isleft + spdiam * .25;
-	    s2 = isrght - spdiam * .25;
-	} else {
-/*           DLARRD has computed IBLOCK and INDEXW for each eigenvalue */
-/*           approximation. */
-/*           choose sigma */
-	    if (usedqd) {
-		s1 = isleft + spdiam * .25;
-		s2 = isrght - spdiam * .25;
-	    } else {
-		tmp = min(isrght,*vu) - max(isleft,*vl);
-		s1 = max(isleft,*vl) + tmp * .25;
-		s2 = min(isrght,*vu) - tmp * .25;
-	    }
-	}
-/*        Compute the negcount at the 1/4 and 3/4 points */
-	if (mb > 1) {
-	    dlarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, &
-		    cnt, &cnt1, &cnt2, &iinfo);
-	}
-	if (mb == 1) {
-	    sigma = gl;
-	    sgndef = 1.;
-	} else if (cnt1 - indl >= indu - cnt2) {
-	    if (irange == 1 && ! forceb) {
-		sigma = max(isleft,gl);
-	    } else if (usedqd) {
-/*              use Gerschgorin bound as shift to get pos def matrix */
-/*              for dqds */
-		sigma = isleft;
-	    } else {
-/*              use approximation of the first desired eigenvalue of the */
-/*              block as shift */
-		sigma = max(isleft,*vl);
-	    }
-	    sgndef = 1.;
-	} else {
-	    if (irange == 1 && ! forceb) {
-		sigma = min(isrght,gu);
-	    } else if (usedqd) {
-/*              use Gerschgorin bound as shift to get neg def matrix */
-/*              for dqds */
-		sigma = isrght;
-	    } else {
-/*              use approximation of the first desired eigenvalue of the */
-/*              block as shift */
-		sigma = min(isrght,*vu);
-	    }
-	    sgndef = -1.;
-	}
-/*        An initial SIGMA has been chosen that will be used for computing */
-/*        T - SIGMA I = L D L^T */
-/*        Define the increment TAU of the shift in case the initial shift */
-/*        needs to be refined to obtain a factorization with not too much */
-/*        element growth. */
-	if (usedqd) {
-/*           The initial SIGMA was to the outer end of the spectrum */
-/*           the matrix is definite and we need not retreat. */
-	    tau = spdiam * eps * *n + *pivmin * 2.;
-	} else {
-	    if (mb > 1) {
-		clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin];
-		avgap = (d__1 = clwdth / (doublereal) (wend - wbegin), abs(
-			d__1));
-		if (sgndef == 1.) {
-/* Computing MAX */
-		    d__1 = wgap[wbegin];
-		    tau = max(d__1,avgap) * .5;
-/* Computing MAX */
-		    d__1 = tau, d__2 = werr[wbegin];
-		    tau = max(d__1,d__2);
-		} else {
-/* Computing MAX */
-		    d__1 = wgap[wend - 1];
-		    tau = max(d__1,avgap) * .5;
-/* Computing MAX */
-		    d__1 = tau, d__2 = werr[wend];
-		    tau = max(d__1,d__2);
-		}
-	    } else {
-		tau = werr[wbegin];
-	    }
-	}
-
-	for (idum = 1; idum <= 6; ++idum) {
-/*           Compute L D L^T factorization of tridiagonal matrix T - sigma I. */
-/*           Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */
-/*           pivots in WORK(2*IN+1:3*IN) */
-	    dpivot = d__[ibegin] - sigma;
-	    work[1] = dpivot;
-	    dmax__ = abs(work[1]);
-	    j = ibegin;
-	    i__2 = in - 1;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		work[(in << 1) + i__] = 1. / work[i__];
-		tmp = e[j] * work[(in << 1) + i__];
-		work[in + i__] = tmp;
-		dpivot = d__[j + 1] - sigma - tmp * e[j];
-		work[i__ + 1] = dpivot;
-/* Computing MAX */
-		d__1 = dmax__, d__2 = abs(dpivot);
-		dmax__ = max(d__1,d__2);
-		++j;
-/* L70: */
-	    }
-/*           check for element growth */
-	    if (dmax__ > spdiam * 64.) {
-		norep = TRUE_;
-	    } else {
-		norep = FALSE_;
-	    }
-	    if (usedqd && ! norep) {
-/*              Ensure the definiteness of the representation */
-/*              All entries of D (of L D L^T) must have the same sign */
-		i__2 = in;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    tmp = sgndef * work[i__];
-		    if (tmp < 0.) {
-			norep = TRUE_;
-		    }
-/* L71: */
-		}
-	    }
-	    if (norep) {
-/*              Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */
-/*              shift which makes the matrix definite. So we should end up */
-/*              here really only in the case of IRANGE = VALRNG or INDRNG. */
-		if (idum == 5) {
-		    if (sgndef == 1.) {
-/*                    The fudged Gerschgorin shift should succeed */
-			sigma = gl - spdiam * 2. * eps * *n - *pivmin * 4.;
-		    } else {
-			sigma = gu + spdiam * 2. * eps * *n + *pivmin * 4.;
-		    }
-		} else {
-		    sigma -= sgndef * tau;
-		    tau *= 2.;
-		}
-	    } else {
-/*              an initial RRR is found */
-		goto L83;
-	    }
-/* L80: */
-	}
-/*        if the program reaches this point, no base representation could be */
-/*        found in MAXTRY iterations. */
-	*info = 2;
-	return 0;
-L83:
-/*        At this point, we have found an initial base representation */
-/*        T - SIGMA I = L D L^T with not too much element growth. */
-/*        Store the shift. */
-	e[iend] = sigma;
-/*        Store D and L. */
-	dcopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1);
-	i__2 = in - 1;
-	dcopy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1);
-	if (mb > 1) {
-
-/*           Perturb each entry of the base representation by a small */
-/*           (but random) relative amount to overcome difficulties with */
-/*           glued matrices. */
-
-	    for (i__ = 1; i__ <= 4; ++i__) {
-		iseed[i__ - 1] = 1;
-/* L122: */
-	    }
-	    i__2 = (in << 1) - 1;
-	    dlarnv_(&c__2, iseed, &i__2, &work[1]);
-	    i__2 = in - 1;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		d__[ibegin + i__ - 1] *= eps * 8. * work[i__] + 1.;
-		e[ibegin + i__ - 1] *= eps * 8. * work[in + i__] + 1.;
-/* L125: */
-	    }
-	    d__[iend] *= eps * 4. * work[in] + 1.;
-
-	}
-
-/*        Don't update the Gerschgorin intervals because keeping track */
-/*        of the updates would be too much work in DLARRV. */
-/*        We update W instead and use it to locate the proper Gerschgorin */
-/*        intervals. */
-/*        Compute the required eigenvalues of L D L' by bisection or dqds */
-	if (! usedqd) {
-/*           If DLARRD has been used, shift the eigenvalue approximations */
-/*           according to their representation. This is necessary for */
-/*           a uniform DLARRV since dqds computes eigenvalues of the */
-/*           shifted representation. In DLARRV, W will always hold the */
-/*           UNshifted eigenvalue approximation. */
-	    i__2 = wend;
-	    for (j = wbegin; j <= i__2; ++j) {
-		w[j] -= sigma;
-		werr[j] += (d__1 = w[j], abs(d__1)) * eps;
-/* L134: */
-	    }
-/*           call DLARRB to reduce eigenvalue error of the approximations */
-/*           from DLARRD */
-	    i__2 = iend - 1;
-	    for (i__ = ibegin; i__ <= i__2; ++i__) {
-/* Computing 2nd power */
-		d__1 = e[i__];
-		work[i__] = d__[i__] * (d__1 * d__1);
-/* L135: */
-	    }
-/*           use bisection to find EV from INDL to INDU */
-	    i__2 = indl - 1;
-	    dlarrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1, 
-		    rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], &
-		    work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, &
-		    iinfo);
-	    if (iinfo != 0) {
-		*info = -4;
-		return 0;
-	    }
-/*           DLARRB computes all gaps correctly except for the last one */
-/*           Record distance to VU/GU */
-/* Computing MAX */
-	    d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]);
-	    wgap[wend] = max(d__1,d__2);
-	    i__2 = indu;
-	    for (i__ = indl; i__ <= i__2; ++i__) {
-		++(*m);
-		iblock[*m] = jblk;
-		indexw[*m] = i__;
-/* L138: */
-	    }
-	} else {
-/*           Call dqds to get all eigs (and then possibly delete unwanted */
-/*           eigenvalues). */
-/*           Note that dqds finds the eigenvalues of the L D L^T representation */
-/*           of T to high relative accuracy. High relative accuracy */
-/*           might be lost when the shift of the RRR is subtracted to obtain */
-/*           the eigenvalues of T. However, T is not guaranteed to define its */
-/*           eigenvalues to high relative accuracy anyway. */
-/*           Set RTOL to the order of the tolerance used in DLASQ2 */
-/*           This is an ESTIMATED error, the worst case bound is 4*N*EPS */
-/*           which is usually too large and requires unnecessary work to be */
-/*           done by bisection when computing the eigenvectors */
-	    rtol = log((doublereal) in) * 4. * eps;
-	    j = ibegin;
-	    i__2 = in - 1;
-	    for (i__ = 1; i__ <= i__2; ++i__) {
-		work[(i__ << 1) - 1] = (d__1 = d__[j], abs(d__1));
-		work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1];
-		++j;
-/* L140: */
-	    }
-	    work[(in << 1) - 1] = (d__1 = d__[iend], abs(d__1));
-	    work[in * 2] = 0.;
-	    dlasq2_(&in, &work[1], &iinfo);
-	    if (iinfo != 0) {
-/*              If IINFO = -5 then an index is part of a tight cluster */
-/*              and should be changed. The index is in IWORK(1) and the */
-/*              gap is in WORK(N+1) */
-		*info = -5;
-		return 0;
-	    } else {
-/*              Test that all eigenvalues are positive as expected */
-		i__2 = in;
-		for (i__ = 1; i__ <= i__2; ++i__) {
-		    if (work[i__] < 0.) {
-			*info = -6;
-			return 0;
-		    }
-/* L149: */
-		}
-	    }
-	    if (sgndef > 0.) {
-		i__2 = indu;
-		for (i__ = indl; i__ <= i__2; ++i__) {
-		    ++(*m);
-		    w[*m] = work[in - i__ + 1];
-		    iblock[*m] = jblk;
-		    indexw[*m] = i__;
-/* L150: */
-		}
-	    } else {
-		i__2 = indu;
-		for (i__ = indl; i__ <= i__2; ++i__) {
-		    ++(*m);
-		    w[*m] = -work[i__];
-		    iblock[*m] = jblk;
-		    indexw[*m] = i__;
-/* L160: */
-		}
-	    }
-	    i__2 = *m;
-	    for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
-/*              the value of RTOL below should be the tolerance in DLASQ2 */
-		werr[i__] = rtol * (d__1 = w[i__], abs(d__1));
-/* L165: */
-	    }
-	    i__2 = *m - 1;
-	    for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
-/*              compute the right gap between the intervals */
-/* Computing MAX */
-		d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + werr[
-			i__]);
-		wgap[i__] = max(d__1,d__2);
-/* L166: */
-	    }
-/* Computing MAX */
-	    d__1 = 0., d__2 = *vu - sigma - (w[*m] + werr[*m]);
-	    wgap[*m] = max(d__1,d__2);
-	}
-/*        proceed with next block */
-	ibegin = iend + 1;
-	wbegin = wend + 1;
-L170:
-	;
-    }
-
-    return 0;
-
-/*     end of DLARRE */
-
-} /* dlarre_ */

3rdparty/lapack/dlarrf.c

@@ -1,423 +0,0 @@
-/* dlarrf.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-
-/* Subroutine */ int dlarrf_(integer *n, doublereal *d__, doublereal *l, 
-	doublereal *ld, integer *clstrt, integer *clend, doublereal *w, 
-	doublereal *wgap, doublereal *werr, doublereal *spdiam, doublereal *
-	clgapl, doublereal *clgapr, doublereal *pivmin, doublereal *sigma, 
-	doublereal *dplus, doublereal *lplus, doublereal *work, integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1, d__2, d__3;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    integer i__;
-    doublereal s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2, 
-	    znm2, growthbound, fail, fact, oldp;
-    integer indx;
-    doublereal prod;
-    integer ktry;
-    doublereal fail2, avgap, ldmax, rdmax;
-    integer shift;
-    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
-	    doublereal *, integer *);
-    logical dorrr1;
-    extern doublereal dlamch_(char *);
-    doublereal ldelta;
-    logical nofail;
-    doublereal mingap, lsigma, rdelta;
-    extern logical disnan_(doublereal *);
-    logical forcer;
-    doublereal rsigma, clwdth;
-    logical sawnan1, sawnan2, tryrrr1;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-/* * */
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  Given the initial representation L D L^T and its cluster of close */
-/*  eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... */
-/*  W( CLEND ), DLARRF finds a new relatively robust representation */
-/*  L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the */
-/*  eigenvalues of L(+) D(+) L(+)^T is relatively isolated. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix (subblock, if the matrix splitted). */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The N diagonal elements of the diagonal matrix D. */
-
-/*  L       (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The (N-1) subdiagonal elements of the unit bidiagonal */
-/*          matrix L. */
-
-/*  LD      (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The (N-1) elements L(i)*D(i). */
-
-/*  CLSTRT  (input) INTEGER */
-/*          The index of the first eigenvalue in the cluster. */
-
-/*  CLEND   (input) INTEGER */
-/*          The index of the last eigenvalue in the cluster. */
-
-/*  W       (input) DOUBLE PRECISION array, dimension >=  (CLEND-CLSTRT+1) */
-/*          The eigenvalue APPROXIMATIONS of L D L^T in ascending order. */
-/*          W( CLSTRT ) through W( CLEND ) form the cluster of relatively */
-/*          close eigenalues. */
-
-/*  WGAP    (input/output) DOUBLE PRECISION array, dimension >=  (CLEND-CLSTRT+1) */
-/*          The separation from the right neighbor eigenvalue in W. */
-
-/*  WERR    (input) DOUBLE PRECISION array, dimension >=  (CLEND-CLSTRT+1) */
-/*          WERR contain the semiwidth of the uncertainty */
-/*          interval of the corresponding eigenvalue APPROXIMATION in W */
-
-/*  SPDIAM (input) estimate of the spectral diameter obtained from the */
-/*          Gerschgorin intervals */
-
-/*  CLGAPL, CLGAPR (input) absolute gap on each end of the cluster. */
-/*          Set by the calling routine to protect against shifts too close */
-/*          to eigenvalues outside the cluster. */
-
-/*  PIVMIN  (input) DOUBLE PRECISION */
-/*          The minimum pivot allowed in the Sturm sequence. */
-
-/*  SIGMA   (output) DOUBLE PRECISION */
-/*          The shift used to form L(+) D(+) L(+)^T. */
-
-/*  DPLUS   (output) DOUBLE PRECISION array, dimension (N) */
-/*          The N diagonal elements of the diagonal matrix D(+). */
-
-/*  LPLUS   (output) DOUBLE PRECISION array, dimension (N-1) */
-/*          The first (N-1) elements of LPLUS contain the subdiagonal */
-/*          elements of the unit bidiagonal matrix L(+). */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N) */
-/*          Workspace. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. External Subroutines .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --work;
-    --lplus;
-    --dplus;
-    --werr;
-    --wgap;
-    --w;
-    --ld;
-    --l;
-    --d__;
-
-    /* Function Body */
-    *info = 0;
-    fact = 2.;
-    eps = dlamch_("Precision");
-    shift = 0;
-    forcer = FALSE_;
-/*     Note that we cannot guarantee that for any of the shifts tried, */
-/*     the factorization has a small or even moderate element growth. */
-/*     There could be Ritz values at both ends of the cluster and despite */
-/*     backing off, there are examples where all factorizations tried */
-/*     (in IEEE mode, allowing zero pivots & infinities) have INFINITE */
-/*     element growth. */
-/*     For this reason, we should use PIVMIN in this subroutine so that at */
-/*     least the L D L^T factorization exists. It can be checked afterwards */
-/*     whether the element growth caused bad residuals/orthogonality. */
-/*     Decide whether the code should accept the best among all */
-/*     representations despite large element growth or signal INFO=1 */
-    nofail = TRUE_;
-
-/*     Compute the average gap length of the cluster */
-    clwdth = (d__1 = w[*clend] - w[*clstrt], abs(d__1)) + werr[*clend] + werr[
-	    *clstrt];
-    avgap = clwdth / (doublereal) (*clend - *clstrt);
-    mingap = min(*clgapl,*clgapr);
-/*     Initial values for shifts to both ends of cluster */
-/* Computing MIN */
-    d__1 = w[*clstrt], d__2 = w[*clend];
-    lsigma = min(d__1,d__2) - werr[*clstrt];
-/* Computing MAX */
-    d__1 = w[*clstrt], d__2 = w[*clend];
-    rsigma = max(d__1,d__2) + werr[*clend];
-/*     Use a small fudge to make sure that we really shift to the outside */
-    lsigma -= abs(lsigma) * 4. * eps;
-    rsigma += abs(rsigma) * 4. * eps;
-/*     Compute upper bounds for how much to back off the initial shifts */
-    ldmax = mingap * .25 + *pivmin * 2.;
-    rdmax = mingap * .25 + *pivmin * 2.;
-/* Computing MAX */
-    d__1 = avgap, d__2 = wgap[*clstrt];
-    ldelta = max(d__1,d__2) / fact;
-/* Computing MAX */
-    d__1 = avgap, d__2 = wgap[*clend - 1];
-    rdelta = max(d__1,d__2) / fact;
-
-/*     Initialize the record of the best representation found */
-
-    s = dlamch_("S");
-    smlgrowth = 1. / s;
-    fail = (doublereal) (*n - 1) * mingap / (*spdiam * eps);
-    fail2 = (doublereal) (*n - 1) * mingap / (*spdiam * sqrt(eps));
-    bestshift = lsigma;
-
-/*     while (KTRY <= KTRYMAX) */
-    ktry = 0;
-    growthbound = *spdiam * 8.;
-L5:
-    sawnan1 = FALSE_;
-    sawnan2 = FALSE_;
-/*     Ensure that we do not back off too much of the initial shifts */
-    ldelta = min(ldmax,ldelta);
-    rdelta = min(rdmax,rdelta);
-/*     Compute the element growth when shifting to both ends of the cluster */
-/*     accept the shift if there is no element growth at one of the two ends */
-/*     Left end */
-    s = -lsigma;
-    dplus[1] = d__[1] + s;
-    if (abs(dplus[1]) < *pivmin) {
-	dplus[1] = -(*pivmin);
-/*        Need to set SAWNAN1 because refined RRR test should not be used */
-/*        in this case */
-	sawnan1 = TRUE_;
-    }
-    max1 = abs(dplus[1]);
-    i__1 = *n - 1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	lplus[i__] = ld[i__] / dplus[i__];
-	s = s * lplus[i__] * l[i__] - lsigma;
-	dplus[i__ + 1] = d__[i__ + 1] + s;
-	if ((d__1 = dplus[i__ + 1], abs(d__1)) < *pivmin) {
-	    dplus[i__ + 1] = -(*pivmin);
-/*           Need to set SAWNAN1 because refined RRR test should not be used */
-/*           in this case */
-	    sawnan1 = TRUE_;
-	}
-/* Computing MAX */
-	d__2 = max1, d__3 = (d__1 = dplus[i__ + 1], abs(d__1));
-	max1 = max(d__2,d__3);
-/* L6: */
-    }
-    sawnan1 = sawnan1 || disnan_(&max1);
-    if (forcer || max1 <= growthbound && ! sawnan1) {
-	*sigma = lsigma;
-	shift = 1;
-	goto L100;
-    }
-/*     Right end */
-    s = -rsigma;
-    work[1] = d__[1] + s;
-    if (abs(work[1]) < *pivmin) {
-	work[1] = -(*pivmin);
-/*        Need to set SAWNAN2 because refined RRR test should not be used */
-/*        in this case */
-	sawnan2 = TRUE_;
-    }
-    max2 = abs(work[1]);
-    i__1 = *n - 1;
-    for (i__ = 1; i__ <= i__1; ++i__) {
-	work[*n + i__] = ld[i__] / work[i__];
-	s = s * work[*n + i__] * l[i__] - rsigma;
-	work[i__ + 1] = d__[i__ + 1] + s;
-	if ((d__1 = work[i__ + 1], abs(d__1)) < *pivmin) {
-	    work[i__ + 1] = -(*pivmin);
-/*           Need to set SAWNAN2 because refined RRR test should not be used */
-/*           in this case */
-	    sawnan2 = TRUE_;
-	}
-/* Computing MAX */
-	d__2 = max2, d__3 = (d__1 = work[i__ + 1], abs(d__1));
-	max2 = max(d__2,d__3);
-/* L7: */
-    }
-    sawnan2 = sawnan2 || disnan_(&max2);
-    if (forcer || max2 <= growthbound && ! sawnan2) {
-	*sigma = rsigma;
-	shift = 2;
-	goto L100;
-    }
-/*     If we are at this point, both shifts led to too much element growth */
-/*     Record the better of the two shifts (provided it didn't lead to NaN) */
-    if (sawnan1 && sawnan2) {
-/*        both MAX1 and MAX2 are NaN */
-	goto L50;
-    } else {
-	if (! sawnan1) {
-	    indx = 1;
-	    if (max1 <= smlgrowth) {
-		smlgrowth = max1;
-		bestshift = lsigma;
-	    }
-	}
-	if (! sawnan2) {
-	    if (sawnan1 || max2 <= max1) {
-		indx = 2;
-	    }
-	    if (max2 <= smlgrowth) {
-		smlgrowth = max2;
-		bestshift = rsigma;
-	    }
-	}
-    }
-/*     If we are here, both the left and the right shift led to */
-/*     element growth. If the element growth is moderate, then */
-/*     we may still accept the representation, if it passes a */
-/*     refined test for RRR. This test supposes that no NaN occurred. */
-/*     Moreover, we use the refined RRR test only for isolated clusters. */
-    if (clwdth < mingap / 128. && min(max1,max2) < fail2 && ! sawnan1 && ! 
-	    sawnan2) {
-	dorrr1 = TRUE_;
-    } else {
-	dorrr1 = FALSE_;
-    }
-    tryrrr1 = TRUE_;
-    if (tryrrr1 && dorrr1) {
-	if (indx == 1) {
-	    tmp = (d__1 = dplus[*n], abs(d__1));
-	    znm2 = 1.;
-	    prod = 1.;
-	    oldp = 1.;
-	    for (i__ = *n - 1; i__ >= 1; --i__) {
-		if (prod <= eps) {
-		    prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] *
-			     work[*n + i__]) * oldp;
-		} else {
-		    prod *= (d__1 = work[*n + i__], abs(d__1));
-		}
-		oldp = prod;
-/* Computing 2nd power */
-		d__1 = prod;
-		znm2 += d__1 * d__1;
-/* Computing MAX */
-		d__2 = tmp, d__3 = (d__1 = dplus[i__] * prod, abs(d__1));
-		tmp = max(d__2,d__3);
-/* L15: */
-	    }
-	    rrr1 = tmp / (*spdiam * sqrt(znm2));
-	    if (rrr1 <= 8.) {
-		*sigma = lsigma;
-		shift = 1;
-		goto L100;
-	    }
-	} else if (indx == 2) {
-	    tmp = (d__1 = work[*n], abs(d__1));
-	    znm2 = 1.;
-	    prod = 1.;
-	    oldp = 1.;
-	    for (i__ = *n - 1; i__ >= 1; --i__) {
-		if (prod <= eps) {
-		    prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] * 
-			    lplus[i__]) * oldp;
-		} else {
-		    prod *= (d__1 = lplus[i__], abs(d__1));
-		}
-		oldp = prod;
-/* Computing 2nd power */
-		d__1 = prod;
-		znm2 += d__1 * d__1;
-/* Computing MAX */
-		d__2 = tmp, d__3 = (d__1 = work[i__] * prod, abs(d__1));
-		tmp = max(d__2,d__3);
-/* L16: */
-	    }
-	    rrr2 = tmp / (*spdiam * sqrt(znm2));
-	    if (rrr2 <= 8.) {
-		*sigma = rsigma;
-		shift = 2;
-		goto L100;
-	    }
-	}
-    }
-L50:
-    if (ktry < 1) {
-/*        If we are here, both shifts failed also the RRR test. */
-/*        Back off to the outside */
-/* Computing MAX */
-	d__1 = lsigma - ldelta, d__2 = lsigma - ldmax;
-	lsigma = max(d__1,d__2);
-/* Computing MIN */
-	d__1 = rsigma + rdelta, d__2 = rsigma + rdmax;
-	rsigma = min(d__1,d__2);
-	ldelta *= 2.;
-	rdelta *= 2.;
-	++ktry;
-	goto L5;
-    } else {
-/*        None of the representations investigated satisfied our */
-/*        criteria. Take the best one we found. */
-	if (smlgrowth < fail || nofail) {
-	    lsigma = bestshift;
-	    rsigma = bestshift;
-	    forcer = TRUE_;
-	    goto L5;
-	} else {
-	    *info = 1;
-	    return 0;
-	}
-    }
-L100:
-    if (shift == 1) {
-    } else if (shift == 2) {
-/*        store new L and D back into DPLUS, LPLUS */
-	dcopy_(n, &work[1], &c__1, &dplus[1], &c__1);
-	i__1 = *n - 1;
-	dcopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1);
-    }
-    return 0;
-
-/*     End of DLARRF */
-
-} /* dlarrf_ */

3rdparty/lapack/dlarrj.c

@@ -1,338 +0,0 @@
-/* dlarrj.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarrj_(integer *n, doublereal *d__, doublereal *e2, 
-	integer *ifirst, integer *ilast, doublereal *rtol, integer *offset, 
-	doublereal *w, doublereal *werr, doublereal *work, integer *iwork, 
-	doublereal *pivmin, doublereal *spdiam, integer *info)
-{
-    /* System generated locals */
-    integer i__1, i__2;
-    doublereal d__1, d__2;
-
-    /* Builtin functions */
-    double log(doublereal);
-
-    /* Local variables */
-    integer i__, j, k, p;
-    doublereal s;
-    integer i1, i2, ii;
-    doublereal fac, mid;
-    integer cnt;
-    doublereal tmp, left;
-    integer iter, nint, prev, next, savi1;
-    doublereal right, width, dplus;
-    integer olnint, maxitr;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  Given the initial eigenvalue approximations of T, DLARRJ */
-/*  does  bisection to refine the eigenvalues of T, */
-/*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */
-/*  guesses for these eigenvalues are input in W, the corresponding estimate */
-/*  of the error in these guesses in WERR. During bisection, intervals */
-/*  [left, right] are maintained by storing their mid-points and */
-/*  semi-widths in the arrays W and WERR respectively. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The N diagonal elements of T. */
-
-/*  E2      (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The Squares of the (N-1) subdiagonal elements of T. */
-
-/*  IFIRST  (input) INTEGER */
-/*          The index of the first eigenvalue to be computed. */
-
-/*  ILAST   (input) INTEGER */
-/*          The index of the last eigenvalue to be computed. */
-
-/*  RTOL   (input) DOUBLE PRECISION */
-/*          Tolerance for the convergence of the bisection intervals. */
-/*          An interval [LEFT,RIGHT] has converged if */
-/*          RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|). */
-
-/*  OFFSET  (input) INTEGER */
-/*          Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET */
-/*          through ILAST-OFFSET elements of these arrays are to be used. */
-
-/*  W       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */
-/*          estimates of the eigenvalues of L D L^T indexed IFIRST through */
-/*          ILAST. */
-/*          On output, these estimates are refined. */
-
-/*  WERR    (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */
-/*          the errors in the estimates of the corresponding elements in W. */
-/*          On output, these errors are refined. */
-
-/*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N) */
-/*          Workspace. */
-
-/*  IWORK   (workspace) INTEGER array, dimension (2*N) */
-/*          Workspace. */
-
-/*  PIVMIN  (input) DOUBLE PRECISION */
-/*          The minimum pivot in the Sturm sequence for T. */
-
-/*  SPDIAM  (input) DOUBLE PRECISION */
-/*          The spectral diameter of T. */
-
-/*  INFO    (output) INTEGER */
-/*          Error flag. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-    /* Parameter adjustments */
-    --iwork;
-    --work;
-    --werr;
-    --w;
-    --e2;
-    --d__;
-
-    /* Function Body */
-    *info = 0;
-
-    maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.)) + 
-	    2;
-
-/*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */
-/*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */
-/*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */
-/*     for an unconverged interval is set to the index of the next unconverged */
-/*     interval, and is -1 or 0 for a converged interval. Thus a linked */
-/*     list of unconverged intervals is set up. */
-
-    i1 = *ifirst;
-    i2 = *ilast;
-/*     The number of unconverged intervals */
-    nint = 0;
-/*     The last unconverged interval found */
-    prev = 0;
-    i__1 = i2;
-    for (i__ = i1; i__ <= i__1; ++i__) {
-	k = i__ << 1;
-	ii = i__ - *offset;
-	left = w[ii] - werr[ii];
-	mid = w[ii];
-	right = w[ii] + werr[ii];
-	width = right - mid;
-/* Computing MAX */
-	d__1 = abs(left), d__2 = abs(right);
-	tmp = max(d__1,d__2);
-/*        The following test prevents the test of converged intervals */
-	if (width < *rtol * tmp) {
-/*           This interval has already converged and does not need refinement. */
-/*           (Note that the gaps might change through refining the */
-/*            eigenvalues, however, they can only get bigger.) */
-/*           Remove it from the list. */
-	    iwork[k - 1] = -1;
-/*           Make sure that I1 always points to the first unconverged interval */
-	    if (i__ == i1 && i__ < i2) {
-		i1 = i__ + 1;
-	    }
-	    if (prev >= i1 && i__ <= i2) {
-		iwork[(prev << 1) - 1] = i__ + 1;
-	    }
-	} else {
-/*           unconverged interval found */
-	    prev = i__;
-/*           Make sure that [LEFT,RIGHT] contains the desired eigenvalue */
-
-/*           Do while( CNT(LEFT).GT.I-1 ) */
-
-	    fac = 1.;
-L20:
-	    cnt = 0;
-	    s = left;
-	    dplus = d__[1] - s;
-	    if (dplus < 0.) {
-		++cnt;
-	    }
-	    i__2 = *n;
-	    for (j = 2; j <= i__2; ++j) {
-		dplus = d__[j] - s - e2[j - 1] / dplus;
-		if (dplus < 0.) {
-		    ++cnt;
-		}
-/* L30: */
-	    }
-	    if (cnt > i__ - 1) {
-		left -= werr[ii] * fac;
-		fac *= 2.;
-		goto L20;
-	    }
-
-/*           Do while( CNT(RIGHT).LT.I ) */
-
-	    fac = 1.;
-L50:
-	    cnt = 0;
-	    s = right;
-	    dplus = d__[1] - s;
-	    if (dplus < 0.) {
-		++cnt;
-	    }
-	    i__2 = *n;
-	    for (j = 2; j <= i__2; ++j) {
-		dplus = d__[j] - s - e2[j - 1] / dplus;
-		if (dplus < 0.) {
-		    ++cnt;
-		}
-/* L60: */
-	    }
-	    if (cnt < i__) {
-		right += werr[ii] * fac;
-		fac *= 2.;
-		goto L50;
-	    }
-	    ++nint;
-	    iwork[k - 1] = i__ + 1;
-	    iwork[k] = cnt;
-	}
-	work[k - 1] = left;
-	work[k] = right;
-/* L75: */
-    }
-    savi1 = i1;
-
-/*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */
-/*     and while (ITER.LT.MAXITR) */
-
-    iter = 0;
-L80:
-    prev = i1 - 1;
-    i__ = i1;
-    olnint = nint;
-    i__1 = olnint;
-    for (p = 1; p <= i__1; ++p) {
-	k = i__ << 1;
-	ii = i__ - *offset;
-	next = iwork[k - 1];
-	left = work[k - 1];
-	right = work[k];
-	mid = (left + right) * .5;
-/*        semiwidth of interval */
-	width = right - mid;
-/* Computing MAX */
-	d__1 = abs(left), d__2 = abs(right);
-	tmp = max(d__1,d__2);
-	if (width < *rtol * tmp || iter == maxitr) {
-/*           reduce number of unconverged intervals */
-	    --nint;
-/*           Mark interval as converged. */
-	    iwork[k - 1] = 0;
-	    if (i1 == i__) {
-		i1 = next;
-	    } else {
-/*              Prev holds the last unconverged interval previously examined */
-		if (prev >= i1) {
-		    iwork[(prev << 1) - 1] = next;
-		}
-	    }
-	    i__ = next;
-	    goto L100;
-	}
-	prev = i__;
-
-/*        Perform one bisection step */
-
-	cnt = 0;
-	s = mid;
-	dplus = d__[1] - s;
-	if (dplus < 0.) {
-	    ++cnt;
-	}
-	i__2 = *n;
-	for (j = 2; j <= i__2; ++j) {
-	    dplus = d__[j] - s - e2[j - 1] / dplus;
-	    if (dplus < 0.) {
-		++cnt;
-	    }
-/* L90: */
-	}
-	if (cnt <= i__ - 1) {
-	    work[k - 1] = mid;
-	} else {
-	    work[k] = mid;
-	}
-	i__ = next;
-L100:
-	;
-    }
-    ++iter;
-/*     do another loop if there are still unconverged intervals */
-/*     However, in the last iteration, all intervals are accepted */
-/*     since this is the best we can do. */
-    if (nint > 0 && iter <= maxitr) {
-	goto L80;
-    }
-
-
-/*     At this point, all the intervals have converged */
-    i__1 = *ilast;
-    for (i__ = savi1; i__ <= i__1; ++i__) {
-	k = i__ << 1;
-	ii = i__ - *offset;
-/*        All intervals marked by '0' have been refined. */
-	if (iwork[k - 1] == 0) {
-	    w[ii] = (work[k - 1] + work[k]) * .5;
-	    werr[ii] = work[k] - w[ii];
-	}
-/* L110: */
-    }
-
-    return 0;
-
-/*     End of DLARRJ */
-
-} /* dlarrj_ */

3rdparty/lapack/dlarrk.c

@@ -1,193 +0,0 @@
-/* dlarrk.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarrk_(integer *n, integer *iw, doublereal *gl, 
-	doublereal *gu, doublereal *d__, doublereal *e2, doublereal *pivmin, 
-	doublereal *reltol, doublereal *w, doublereal *werr, integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1, d__2;
-
-    /* Builtin functions */
-    double log(doublereal);
-
-    /* Local variables */
-    integer i__, it;
-    doublereal mid, eps, tmp1, tmp2, left, atoli, right;
-    integer itmax;
-    doublereal rtoli, tnorm;
-    extern doublereal dlamch_(char *);
-    integer negcnt;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-/*  Purpose */
-/*  ======= */
-
-/*  DLARRK computes one eigenvalue of a symmetric tridiagonal */
-/*  matrix T to suitable accuracy. This is an auxiliary code to be */
-/*  called from DSTEMR. */
-
-/*  To avoid overflow, the matrix must be scaled so that its */
-/*  largest element is no greater than overflow**(1/2) * */
-/*  underflow**(1/4) in absolute value, and for greatest */
-/*  accuracy, it should not be much smaller than that. */
-
-/*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
-/*  Matrix", Report CS41, Computer Science Dept., Stanford */
-/*  University, July 21, 1966. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the tridiagonal matrix T.  N >= 0. */
-
-/*  IW      (input) INTEGER */
-/*          The index of the eigenvalues to be returned. */
-
-/*  GL      (input) DOUBLE PRECISION */
-/*  GU      (input) DOUBLE PRECISION */
-/*          An upper and a lower bound on the eigenvalue. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The n diagonal elements of the tridiagonal matrix T. */
-
-/*  E2      (input) DOUBLE PRECISION array, dimension (N-1) */
-/*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */
-
-/*  PIVMIN  (input) DOUBLE PRECISION */
-/*          The minimum pivot allowed in the Sturm sequence for T. */
-
-/*  RELTOL  (input) DOUBLE PRECISION */
-/*          The minimum relative width of an interval.  When an interval */
-/*          is narrower than RELTOL times the larger (in */
-/*          magnitude) endpoint, then it is considered to be */
-/*          sufficiently small, i.e., converged.  Note: this should */
-/*          always be at least radix*machine epsilon. */
-
-/*  W       (output) DOUBLE PRECISION */
-
-/*  WERR    (output) DOUBLE PRECISION */
-/*          The error bound on the corresponding eigenvalue approximation */
-/*          in W. */
-
-/*  INFO    (output) INTEGER */
-/*          = 0:       Eigenvalue converged */
-/*          = -1:      Eigenvalue did NOT converge */
-
-/*  Internal Parameters */
-/*  =================== */
-
-/*  FUDGE   DOUBLE PRECISION, default = 2 */
-/*          A "fudge factor" to widen the Gershgorin intervals. */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     Get machine constants */
-    /* Parameter adjustments */
-    --e2;
-    --d__;
-
-    /* Function Body */
-    eps = dlamch_("P");
-/* Computing MAX */
-    d__1 = abs(*gl), d__2 = abs(*gu);
-    tnorm = max(d__1,d__2);
-    rtoli = *reltol;
-    atoli = *pivmin * 4.;
-    itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.)) + 2;
-    *info = -1;
-    left = *gl - tnorm * 2. * eps * *n - *pivmin * 4.;
-    right = *gu + tnorm * 2. * eps * *n + *pivmin * 4.;
-    it = 0;
-L10:
-
-/*     Check if interval converged or maximum number of iterations reached */
-
-    tmp1 = (d__1 = right - left, abs(d__1));
-/* Computing MAX */
-    d__1 = abs(right), d__2 = abs(left);
-    tmp2 = max(d__1,d__2);
-/* Computing MAX */
-    d__1 = max(atoli,*pivmin), d__2 = rtoli * tmp2;
-    if (tmp1 < max(d__1,d__2)) {
-	*info = 0;
-	goto L30;
-    }
-    if (it > itmax) {
-	goto L30;
-    }
-
-/*     Count number of negative pivots for mid-point */
-
-    ++it;
-    mid = (left + right) * .5;
-    negcnt = 0;
-    tmp1 = d__[1] - mid;
-    if (abs(tmp1) < *pivmin) {
-	tmp1 = -(*pivmin);
-    }
-    if (tmp1 <= 0.) {
-	++negcnt;
-    }
-
-    i__1 = *n;
-    for (i__ = 2; i__ <= i__1; ++i__) {
-	tmp1 = d__[i__] - e2[i__ - 1] / tmp1 - mid;
-	if (abs(tmp1) < *pivmin) {
-	    tmp1 = -(*pivmin);
-	}
-	if (tmp1 <= 0.) {
-	    ++negcnt;
-	}
-/* L20: */
-    }
-    if (negcnt >= *iw) {
-	right = mid;
-    } else {
-	left = mid;
-    }
-    goto L10;
-L30:
-
-/*     Converged or maximum number of iterations reached */
-
-    *w = (left + right) * .5;
-    *werr = (d__1 = right - left, abs(d__1)) * .5;
-    return 0;
-
-/*     End of DLARRK */
-
-} /* dlarrk_ */

3rdparty/lapack/dlarrr.c

@@ -1,176 +0,0 @@
-/* dlarrr.f -- translated by f2c (version 20061008).
-   You must link the resulting object file with libf2c:
-	on Microsoft Windows system, link with libf2c.lib;
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
-	or, if you install libf2c.a in a standard place, with -lf2c -lm
-	-- in that order, at the end of the command line, as in
-		cc *.o -lf2c -lm
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
-		http://www.netlib.org/f2c/libf2c.zip
-*/
-
-#include "clapack.h"
-
-
-/* Subroutine */ int dlarrr_(integer *n, doublereal *d__, doublereal *e, 
-	integer *info)
-{
-    /* System generated locals */
-    integer i__1;
-    doublereal d__1;
-
-    /* Builtin functions */
-    double sqrt(doublereal);
-
-    /* Local variables */
-    integer i__;
-    doublereal eps, tmp, tmp2, rmin;
-    extern doublereal dlamch_(char *);
-    doublereal offdig, safmin;
-    logical yesrel;
-    doublereal smlnum, offdig2;
-
-
-/*  -- LAPACK auxiliary routine (version 3.2) -- */
-/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
-/*     November 2006 */
-
-/*     .. Scalar Arguments .. */
-/*     .. */
-/*     .. Array Arguments .. */
-/*     .. */
-
-
-/*  Purpose */
-/*  ======= */
-
-/*  Perform tests to decide whether the symmetric tridiagonal matrix T */
-/*  warrants expensive computations which guarantee high relative accuracy */
-/*  in the eigenvalues. */
-
-/*  Arguments */
-/*  ========= */
-
-/*  N       (input) INTEGER */
-/*          The order of the matrix. N > 0. */
-
-/*  D       (input) DOUBLE PRECISION array, dimension (N) */
-/*          The N diagonal elements of the tridiagonal matrix T. */
-
-/*  E       (input/output) DOUBLE PRECISION array, dimension (N) */
-/*          On entry, the first (N-1) entries contain the subdiagonal */
-/*          elements of the tridiagonal matrix T; E(N) is set to ZERO. */
-
-/*  INFO    (output) INTEGER */
-/*          INFO = 0(default) : the matrix warrants computations preserving */
-/*                              relative accuracy. */
-/*          INFO = 1          : the matrix warrants computations guaranteeing */
-/*                              only absolute accuracy. */
-
-/*  Further Details */
-/*  =============== */
-
-/*  Based on contributions by */
-/*     Beresford Parlett, University of California, Berkeley, USA */
-/*     Jim Demmel, University of California, Berkeley, USA */
-/*     Inderjit Dhillon, University of Texas, Austin, USA */
-/*     Osni Marques, LBNL/NERSC, USA */
-/*     Christof Voemel, University of California, Berkeley, USA */
-
-/*  ===================================================================== */
-
-/*     .. Parameters .. */
-/*     .. */
-/*     .. Local Scalars .. */
-/*     .. */
-/*     .. External Functions .. */
-/*     .. */
-/*     .. Intrinsic Functions .. */
-/*     .. */
-/*     .. Executable Statements .. */
-
-/*     As a default, do NOT go for relative-accuracy preserving computations. */
-    /* Parameter adjustments */
-    --e;
-    --d__;
-
-    /* Function Body */
-    *info = 1;
-    safmin = dlamch_("Safe minimum");
-    eps = dlamch_("Precision");
-    smlnum = safmin / eps;
-    rmin = sqrt(smlnum);
-/*     Tests for relative accuracy */
-
-/*     Test for scaled diagonal dominance */
-/*     Scale the diagonal entries to one and check whether the sum of the */
-/*     off-diagonals is less than one */
-
-/*     The sdd relative error bounds have a 1/(1- 2*x) factor in them, */
-/*     x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative */
-/*     accuracy is promised.  In the notation of the code fragment below, */
-/*     1/(1 - (OFFDIG + OFFDIG2)) is the condition number. */
-/*     We don't think it is worth going into "sdd mode" unless the relative */
-/*     condition number is reasonable, not 1/macheps. */
-/*     The threshold should be compatible with other thresholds used in the */
-/*     code. We set  OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds */
-/*     to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000 */
-/*     instead of the current OFFDIG + OFFDIG2 < 1 */
-
-    yesrel = TRUE_;
-    offdig = 0.;
-    tmp = sqrt((abs(d__[1])));
-    if (tmp < rmin) {
-	yesrel = FALSE_;
-    }
-    if (! yesrel) {
-	goto L11;
-    }
-    i__1 = *n;
-    for (i__ = 2; i__ <= i__1; ++i__) {
-	tmp2 = sqrt((d__1 = d__[i__], abs(d__1)));
-	if (tmp2 < rmin) {
-	    yesrel = FALSE_;
-	}
-	if (! yesrel) {
-	    goto L11;
-	}
-	offdig2 = (d__1 = e[i__ - 1], abs(d__1)) / (tmp * tmp2);
-	if (offdig + offdig2 >= .999) {
-	    yesrel = FALSE_;
-	}
-	if (! yesrel) {
-	    goto L11;
-	}
-	tmp = tmp2;
-	offdig = offdig2;
-/* L10: */
-    }
-L11:
-    if (yesrel) {
-	*info = 0;
-	return 0;
-    } else {
-    }
-
-
-/*     *** MORE TO BE IMPLEMENTED *** */
-
-
-/*     Test if the lower bidiagonal matrix L from T = L D L^T */
-/*     (zero shift facto) is well conditioned */
-
-
-/*     Test if the upper bidiagonal matrix U from T = U D U^T */
-/*     (zero shift facto) is well conditioned. */
-/*     In this case, the matrix needs to be flipped and, at the end */
-/*     of the eigenvector computation, the flip needs to be applied */
-/*     to the computed eigenvectors (and the support) */
-
-
-    return 0;
-
-/*     END OF DLARRR */
-
-} /* dlarrr_ */