generic-library/opencv
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

do not use Lapack anymore

Browse Source
This commit is contained in:
Vadim Pisarevsky 2011-04-25 21:50:25 +00:00
parent 9ac3a35175
commit 4aaa2700f6
313 changed files with 29 additions and 100933 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
3rdparty/CMakeLists.txt vendored
View File

@ -1,14 +1,13 @@
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()

100
3rdparty/include/cblas.h vendored
View File

@ -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 */

3715
3rdparty/include/clapack.h vendored
View File

File diff suppressed because it is too large Load Diff

253
3rdparty/include/f2c.h vendored
View File

@ -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

64
3rdparty/lapack/CMakeLists.txt vendored
View File

@ -1,64 +0,0 @@
# ----------------------------------------------------------------------------
# CMake file for opencv_lapack. See root CMakeLists.txt
#
# ----------------------------------------------------------------------------
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()

36
3rdparty/lapack/COPYING vendored
View File

@ -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.

101
3rdparty/lapack/dasum.c vendored
View File

@ -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_ */

107
3rdparty/lapack/daxpy.c vendored
View File

@ -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_ */

514
3rdparty/lapack/dbdsdc.c vendored
View File

@ -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_ */

918
3rdparty/lapack/dbdsqr.c vendored
View File

@ -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_ */

107
3rdparty/lapack/dcopy.c vendored
View File

@ -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_ */

110
3rdparty/lapack/ddot.c vendored
View File

@ -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_ */

304
3rdparty/lapack/dgebd2.c vendored
View File

@ -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_ */

336
3rdparty/lapack/dgebrd.c vendored
View File

@ -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_ */

157
3rdparty/lapack/dgelq2.c vendored
View File

@ -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_ */

251
3rdparty/lapack/dgelqf.c vendored
View File

@ -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_ */

515
3rdparty/lapack/dgels.c vendored
View File

@ -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_ */

693
3rdparty/lapack/dgelsd.c vendored
View File

@ -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_ */

389
3rdparty/lapack/dgemm.c vendored
View File

@ -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_ */

241
3rdparty/lapack/dgemv_custom.c vendored
View File

@ -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_ */

161
3rdparty/lapack/dgeqr2.c vendored
View File

@ -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_ */

252
3rdparty/lapack/dgeqrf.c vendored
View File

@ -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_ */

165
3rdparty/lapack/dger_custom.c vendored
View File

@ -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_ */

1609
3rdparty/lapack/dgesdd.c vendored
View File

File diff suppressed because it is too large Load Diff

138
3rdparty/lapack/dgesv.c vendored
View File

@ -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_ */

193
3rdparty/lapack/dgetf2.c vendored
View File

@ -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_ */

219
3rdparty/lapack/dgetrf.c vendored
View File

@ -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_ */

264
3rdparty/lapack/dgetri.c vendored
View File

@ -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_ */

186
3rdparty/lapack/dgetrs.c vendored
View File

@ -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_ */

72
3rdparty/lapack/dlabad.c vendored
View File

@ -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_ */

434
3rdparty/lapack/dlabrd.c vendored
View File

@ -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_ */

125
3rdparty/lapack/dlacpy.c vendored
View File

@ -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_ */

142
3rdparty/lapack/dlae2.c vendored
View File

@ -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_ */

640
3rdparty/lapack/dlaebz.c vendored
View File

@ -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_ */

440
3rdparty/lapack/dlaed0.c vendored
View File

@ -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_ */

249
3rdparty/lapack/dlaed1.c vendored
View File

@ -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_ */

532
3rdparty/lapack/dlaed2.c vendored
View File

@ -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_ */

338
3rdparty/lapack/dlaed3.c vendored
View File

@ -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_ */

954
3rdparty/lapack/dlaed4.c vendored
View File

@ -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_ */

148
3rdparty/lapack/dlaed5.c vendored
View File

@ -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_ */

374
3rdparty/lapack/dlaed6.c vendored
View File

@ -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_ */

354
3rdparty/lapack/dlaed7.c vendored
View File

@ -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_ */

475
3rdparty/lapack/dlaed8.c vendored
View File

@ -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_ */

274
3rdparty/lapack/dlaed9.c vendored
View File

@ -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_ */

287
3rdparty/lapack/dlaeda.c vendored
View File

@ -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_ */

188
3rdparty/lapack/dlaev2.c vendored
View File

@ -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_ */

224
3rdparty/lapack/dlagtf.c vendored
View File

@ -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_ */

351
3rdparty/lapack/dlagts.c vendored
View File

@ -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_ */

58
3rdparty/lapack/dlaisnan.c vendored
View File

@ -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_ */

473
3rdparty/lapack/dlals0.c vendored
View File

@ -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_ */

456
3rdparty/lapack/dlalsa.c vendored
View File

@ -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_ */

529
3rdparty/lapack/dlalsd.c vendored
View File

@ -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_ */

58
3rdparty/lapack/dlamch_custom.c vendored
View File

@ -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
};

131
3rdparty/lapack/dlamrg.c vendored
View File

@ -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_ */

218
3rdparty/lapack/dlaneg.c vendored
View File

@ -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_ */

199
3rdparty/lapack/dlange.c vendored
View File

@ -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_ */

166
3rdparty/lapack/dlanst.c vendored
View File

@ -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_ */

239
3rdparty/lapack/dlansy.c vendored
View File

@ -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_ */

73
3rdparty/lapack/dlapy2.c vendored
View File

@ -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_ */

441
3rdparty/lapack/dlar1v.c vendored
View File

@ -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_ */

193
3rdparty/lapack/dlarf.c vendored
View File

@ -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_ */

774
3rdparty/lapack/dlarfb.c vendored
View File

@ -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_ */

170
3rdparty/lapack/dlarfg.c vendored
View File

@ -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_ */

192
3rdparty/lapack/dlarfp.c vendored
View File

@ -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_ */

325
3rdparty/lapack/dlarft.c vendored
View File

@ -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_ */

146
3rdparty/lapack/dlarnv.c vendored
View File

@ -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_ */

156
3rdparty/lapack/dlarra.c vendored
View File

@ -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_ */

350
3rdparty/lapack/dlarrb.c vendored
View File

@ -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_ */

183
3rdparty/lapack/dlarrc.c vendored
View File

@ -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_ */

793
3rdparty/lapack/dlarrd.c vendored
View File

@ -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_ */

861
3rdparty/lapack/dlarre.c vendored
View File

@ -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_ */

423
3rdparty/lapack/dlarrf.c vendored
View File

@ -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_ */

338
3rdparty/lapack/dlarrj.c vendored
View File

@ -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_ */

193
3rdparty/lapack/dlarrk.c vendored
View File

@ -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_ */

176
3rdparty/lapack/dlarrr.c vendored
View File

@ -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_ */

988
3rdparty/lapack/dlarrv.c vendored
View File

@ -1,988 +0,0 @@
/* dlarrv.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 = 0.;
static integer c__1 = 1;
static integer c__2 = 2;
/* Subroutine */ int dlarrv_(integer *n, doublereal *vl, doublereal *vu,
doublereal *d__, doublereal *l, doublereal *pivmin, integer *isplit,
integer *m, integer *dol, integer *dou, doublereal *minrgp,
doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr,
doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers,
doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
logical L__1;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer minwsize, i__, j, k, p, q, miniwsize, ii;
doublereal gl;
integer im, in;
doublereal gu, gap, eps, tau, tol, tmp;
integer zto;
doublereal ztz;
integer iend, jblk;
doublereal lgap;
integer done;
doublereal rgap, left;
integer wend, iter;
doublereal bstw;
integer itmp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
integer indld;
doublereal fudge;
integer idone;
doublereal sigma;
integer iinfo, iindr;
doublereal resid;
logical eskip;
doublereal right;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer nclus, zfrom;
doublereal rqtol;
integer iindc1, iindc2;
extern /* Subroutine */ int dlar1v_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, logical *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *);
logical stp2ii;
doublereal lambda;
extern doublereal dlamch_(char *);
integer ibegin, indeig;
logical needbs;
integer indlld;
doublereal sgndef, mingma;
extern /* Subroutine */ int dlarrb_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *);
integer oldien, oldncl, wbegin;
doublereal spdiam;
integer negcnt;
extern /* Subroutine */ int dlarrf_(integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
integer oldcls;
doublereal savgap;
integer ndepth;
doublereal ssigma;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
logical usedbs;
integer iindwk, offset;
doublereal gaptol;
integer newcls, oldfst, indwrk, windex, oldlst;
logical usedrq;
integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl;
doublereal bstres;
integer newsiz, zusedu, zusedw;
doublereal nrminv, rqcorr;
logical tryrqc;
integer isupmx;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARRV computes the eigenvectors of the tridiagonal matrix */
/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
/* The input eigenvalues should have been computed by DLARRE. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* Lower and upper bounds of the interval that contains the desired */
/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
/* end of the extremal eigenvalues in the desired RANGE. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the N diagonal elements of the diagonal matrix D. */
/* On exit, D may be overwritten. */
/* L (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the (N-1) subdiagonal elements of the unit */
/* bidiagonal matrix L are in elements 1 to N-1 of L */
/* (if the matrix is not splitted.) At the end of each block */
/* is stored the corresponding shift as given by DLARRE. */
/* On exit, L is overwritten. */
/* PIVMIN (in) DOUBLE PRECISION */
/* The minimum pivot allowed in the Sturm sequence. */
/* ISPLIT (input) 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. */
/* M (input) INTEGER */
/* The total number of input eigenvalues. 0 <= M <= N. */
/* DOL (input) INTEGER */
/* DOU (input) INTEGER */
/* If the user wants to compute only selected eigenvectors from all */
/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
/* Or else the setting DOL=1, DOU=M should be applied. */
/* Note that DOL and DOU refer to the order in which the eigenvalues */
/* are stored in W. */
/* If the user wants to compute only selected eigenpairs, then */
/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
/* computed eigenvectors. All other columns of Z are set to zero. */
/* MINRGP (input) DOUBLE PRECISION */
/* 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|) ) */
/* W (input/output) DOUBLE PRECISION array, dimension (N) */
/* The first M elements of W contain the APPROXIMATE eigenvalues for */
/* which eigenvectors are to be computed. The eigenvalues */
/* should be grouped by split-off block and ordered from */
/* smallest to largest within the block ( The output array */
/* W from DLARRE is expected here ). Furthermore, they are with */
/* respect to the shift of the corresponding root representation */
/* for their block. On exit, W holds the eigenvalues of the */
/* UNshifted matrix. */
/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the semiwidth of the uncertainty */
/* interval of the corresponding eigenvalue in W */
/* WGAP (input/output) DOUBLE PRECISION array, dimension (N) */
/* The separation from the right neighbor eigenvalue in W. */
/* IBLOCK (input) 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 (input) 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 the second block. */
/* 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)). The Gerschgorin intervals should */
/* be computed from the original UNshifted matrix. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
/* If INFO = 0, the first M columns of Z contain the */
/* orthonormal eigenvectors of the matrix T */
/* corresponding to the input eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The I-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
/* ISUPPZ( 2*I ). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (12*N) */
/* IWORK (workspace) INTEGER array, dimension (7*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: A problem occured in DLARRV. */
/* < 0: One of the called subroutines signaled an internal problem. */
/* Needs inspection of the corresponding parameter IINFO */
/* for further information. */
/* =-1: Problem in DLARRB when refining a child's eigenvalues. */
/* =-2: Problem in DLARRF when computing the RRR of a child. */
/* When a child is inside a tight cluster, it can be difficult */
/* to find an RRR. A partial remedy from the user's point of */
/* view is to make the parameter MINRGP smaller and recompile. */
/* However, as the orthogonality of the computed vectors is */
/* proportional to 1/MINRGP, the user should be aware that */
/* he might be trading in precision when he decreases MINRGP. */
/* =-3: Problem in DLARRB when refining a single eigenvalue */
/* after the Rayleigh correction was rejected. */
/* = 5: The Rayleigh Quotient Iteration failed to converge to */
/* full accuracy in MAXITR steps. */
/* 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 .. */
/* .. */
/* The first N entries of WORK are reserved for the eigenvalues */
/* Parameter adjustments */
--d__;
--l;
--isplit;
--w;
--werr;
--wgap;
--iblock;
--indexw;
--gers;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
indld = *n + 1;
indlld = (*n << 1) + 1;
indwrk = *n * 3 + 1;
minwsize = *n * 12;
i__1 = minwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L5: */
}
/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
/* factorization used to compute the FP vector */
iindr = 0;
/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
/* layer and the one above. */
iindc1 = *n;
iindc2 = *n << 1;
iindwk = *n * 3 + 1;
miniwsize = *n * 7;
i__1 = miniwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
zusedl = 1;
if (*dol > 1) {
/* Set lower bound for use of Z */
zusedl = *dol - 1;
}
zusedu = *m;
if (*dou < *m) {
/* Set lower bound for use of Z */
zusedu = *dou + 1;
}
/* The width of the part of Z that is used */
zusedw = zusedu - zusedl + 1;
dlaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz);
eps = dlamch_("Precision");
rqtol = eps * 2.;
/* Set expert flags for standard code. */
tryrqc = TRUE_;
if (*dol == 1 && *dou == *m) {
} else {
/* Only selected eigenpairs are computed. Since the other evalues */
/* are not refined by RQ iteration, bisection has to compute to full */
/* accuracy. */
*rtol1 = eps * 4.;
*rtol2 = eps * 4.;
}
/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
/* desired eigenvalues. The support of the nonzero eigenvector */
/* entries is contained in the interval IBEGIN:IEND. */
/* Remark that if k eigenpairs are desired, then the eigenvectors */
/* are stored in k contiguous columns of Z. */
/* DONE is the number of eigenvectors already computed */
done = 0;
ibegin = 1;
wbegin = 1;
i__1 = iblock[*m];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = isplit[jblk];
sigma = l[iend];
/* Find the eigenvectors of the submatrix indexed IBEGIN */
/* through IEND. */
wend = wbegin - 1;
L15:
if (wend < *m) {
if (iblock[wend + 1] == jblk) {
++wend;
goto L15;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L170;
} else if (wend < *dol || wbegin > *dou) {
ibegin = iend + 1;
wbegin = wend + 1;
goto L170;
}
/* Find local spectral diameter of the block */
gl = gers[(ibegin << 1) - 1];
gu = gers[ibegin * 2];
i__2 = iend;
for (i__ = ibegin + 1; 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);
/* L20: */
}
spdiam = gu - gl;
/* OLDIEN is the last index of the previous block */
oldien = ibegin - 1;
/* Calculate the size of the current block */
in = iend - ibegin + 1;
/* The number of eigenvalues in the current block */
im = wend - wbegin + 1;
/* This is for a 1x1 block */
if (ibegin == iend) {
++done;
z__[ibegin + wbegin * z_dim1] = 1.;
isuppz[(wbegin << 1) - 1] = ibegin;
isuppz[wbegin * 2] = ibegin;
w[wbegin] += sigma;
work[wbegin] = w[wbegin];
ibegin = iend + 1;
++wbegin;
goto L170;
}
/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
/* Note that these can be approximations, in this case, the corresp. */
/* entries of WERR give the size of the uncertainty interval. */
/* The eigenvalue approximations will be refined when necessary as */
/* high relative accuracy is required for the computation of the */
/* corresponding eigenvectors. */
dcopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
/* We store in W the eigenvalue approximations w.r.t. the original */
/* matrix T. */
i__2 = im;
for (i__ = 1; i__ <= i__2; ++i__) {
w[wbegin + i__ - 1] += sigma;
/* L30: */
}
/* NDEPTH is the current depth of the representation tree */
ndepth = 0;
/* PARITY is either 1 or 0 */
parity = 1;
/* NCLUS is the number of clusters for the next level of the */
/* representation tree, we start with NCLUS = 1 for the root */
nclus = 1;
iwork[iindc1 + 1] = 1;
iwork[iindc1 + 2] = im;
/* IDONE is the number of eigenvectors already computed in the current */
/* block */
idone = 0;
/* loop while( IDONE.LT.IM ) */
/* generate the representation tree for the current block and */
/* compute the eigenvectors */
L40:
if (idone < im) {
/* This is a crude protection against infinitely deep trees */
if (ndepth > *m) {
*info = -2;
return 0;
}
/* breadth first processing of the current level of the representation */
/* tree: OLDNCL = number of clusters on current level */
oldncl = nclus;
/* reset NCLUS to count the number of child clusters */
nclus = 0;
parity = 1 - parity;
if (parity == 0) {
oldcls = iindc1;
newcls = iindc2;
} else {
oldcls = iindc2;
newcls = iindc1;
}
/* Process the clusters on the current level */
i__2 = oldncl;
for (i__ = 1; i__ <= i__2; ++i__) {
j = oldcls + (i__ << 1);
/* OLDFST, OLDLST = first, last index of current cluster. */
/* cluster indices start with 1 and are relative */
/* to WBEGIN when accessing W, WGAP, WERR, Z */
oldfst = iwork[j - 1];
oldlst = iwork[j];
if (ndepth > 0) {
/* Retrieve relatively robust representation (RRR) of cluster */
/* that has been computed at the previous level */
/* The RRR is stored in Z and overwritten once the eigenvectors */
/* have been computed or when the cluster is refined */
if (*dol == 1 && *dou == *m) {
/* Get representation from location of the leftmost evalue */
/* of the cluster */
j = wbegin + oldfst - 1;
} else {
if (wbegin + oldfst - 1 < *dol) {
/* Get representation from the left end of Z array */
j = *dol - 1;
} else if (wbegin + oldfst - 1 > *dou) {
/* Get representation from the right end of Z array */
j = *dou;
} else {
j = wbegin + oldfst - 1;
}
}
dcopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin]
, &c__1);
i__3 = in - 1;
dcopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[
ibegin], &c__1);
sigma = z__[iend + (j + 1) * z_dim1];
/* Set the corresponding entries in Z to zero */
dlaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j
* z_dim1], ldz);
}
/* Compute DL and DLL of current RRR */
i__3 = iend - 1;
for (j = ibegin; j <= i__3; ++j) {
tmp = d__[j] * l[j];
work[indld - 1 + j] = tmp;
work[indlld - 1 + j] = tmp * l[j];
/* L50: */
}
if (ndepth > 0) {
/* P and Q are index of the first and last eigenvalue to compute */
/* within the current block */
p = indexw[wbegin - 1 + oldfst];
q = indexw[wbegin - 1 + oldlst];
/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
/* thru' Q-OFFSET elements of these arrays are to be used. */
/* OFFSET = P-OLDFST */
offset = indexw[wbegin] - 1;
/* perform limited bisection (if necessary) to get approximate */
/* eigenvalues to the precision needed. */
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
&q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
wbegin], &werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &in, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* We also recompute the extremal gaps. W holds all eigenvalues */
/* of the unshifted matrix and must be used for computation */
/* of WGAP, the entries of WORK might stem from RRRs with */
/* different shifts. The gaps from WBEGIN-1+OLDFST to */
/* WBEGIN-1+OLDLST are correctly computed in DLARRB. */
/* However, we only allow the gaps to become greater since */
/* this is what should happen when we decrease WERR */
if (oldfst > 1) {
/* Computing MAX */
d__1 = wgap[wbegin + oldfst - 2], d__2 = w[wbegin +
oldfst - 1] - werr[wbegin + oldfst - 1] - w[
wbegin + oldfst - 2] - werr[wbegin + oldfst -
2];
wgap[wbegin + oldfst - 2] = max(d__1,d__2);
}
if (wbegin + oldlst - 1 < wend) {
/* Computing MAX */
d__1 = wgap[wbegin + oldlst - 1], d__2 = w[wbegin +
oldlst] - werr[wbegin + oldlst] - w[wbegin +
oldlst - 1] - werr[wbegin + oldlst - 1];
wgap[wbegin + oldlst - 1] = max(d__1,d__2);
}
/* Each time the eigenvalues in WORK get refined, we store */
/* the newly found approximation with all shifts applied in W */
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
/* L53: */
}
}
/* Process the current node. */
newfst = oldfst;
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
if (j == oldlst) {
/* we are at the right end of the cluster, this is also the */
/* boundary of the child cluster */
newlst = j;
} else if (wgap[wbegin + j - 1] >= *minrgp * (d__1 = work[
wbegin + j - 1], abs(d__1))) {
/* the right relative gap is big enough, the child cluster */
/* (NEWFST,..,NEWLST) is well separated from the following */
newlst = j;
} else {
/* inside a child cluster, the relative gap is not */
/* big enough. */
goto L140;
}
/* Compute size of child cluster found */
newsiz = newlst - newfst + 1;
/* NEWFTT is the place in Z where the new RRR or the computed */
/* eigenvector is to be stored */
if (*dol == 1 && *dou == *m) {
/* Store representation at location of the leftmost evalue */
/* of the cluster */
newftt = wbegin + newfst - 1;
} else {
if (wbegin + newfst - 1 < *dol) {
/* Store representation at the left end of Z array */
newftt = *dol - 1;
} else if (wbegin + newfst - 1 > *dou) {
/* Store representation at the right end of Z array */
newftt = *dou;
} else {
newftt = wbegin + newfst - 1;
}
}
if (newsiz > 1) {
/* Current child is not a singleton but a cluster. */
/* Compute and store new representation of child. */
/* Compute left and right cluster gap. */
/* LGAP and RGAP are not computed from WORK because */
/* the eigenvalue approximations may stem from RRRs */
/* different shifts. However, W hold all eigenvalues */
/* of the unshifted matrix. Still, the entries in WGAP */
/* have to be computed from WORK since the entries */
/* in W might be of the same order so that gaps are not */
/* exhibited correctly for very close eigenvalues. */
if (newfst == 1) {
/* Computing MAX */
d__1 = 0., d__2 = w[wbegin] - werr[wbegin] - *vl;
lgap = max(d__1,d__2);
} else {
lgap = wgap[wbegin + newfst - 2];
}
rgap = wgap[wbegin + newlst - 1];
/* Compute left- and rightmost eigenvalue of child */
/* to high precision in order to shift as close */
/* as possible and obtain as large relative gaps */
/* as possible */
for (k = 1; k <= 2; ++k) {
if (k == 1) {
p = indexw[wbegin - 1 + newfst];
} else {
p = indexw[wbegin - 1 + newlst];
}
offset = indexw[wbegin] - 1;
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &p, &p, &rqtol, &rqtol, &offset, &
work[wbegin], &wgap[wbegin], &werr[wbegin]
, &work[indwrk], &iwork[iindwk], pivmin, &
spdiam, &in, &iinfo);
/* L55: */
}
if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
> *dou) {
/* if the cluster contains no desired eigenvalues */
/* skip the computation of that branch of the rep. tree */
/* We could skip before the refinement of the extremal */
/* eigenvalues of the child, but then the representation */
/* tree could be different from the one when nothing is */
/* skipped. For this reason we skip at this place. */
idone = idone + newlst - newfst + 1;
goto L139;
}
/* Compute RRR of child cluster. */
/* Note that the new RRR is stored in Z */
/* DLARRF needs LWORK = 2*N */
dlarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
ibegin - 1], &newfst, &newlst, &work[wbegin],
&wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
&rgap, pivmin, &tau, &z__[ibegin + newftt *
z_dim1], &z__[ibegin + (newftt + 1) * z_dim1],
&work[indwrk], &iinfo);
if (iinfo == 0) {
/* a new RRR for the cluster was found by DLARRF */
/* update shift and store it */
ssigma = sigma + tau;
z__[iend + (newftt + 1) * z_dim1] = ssigma;
/* WORK() are the midpoints and WERR() the semi-width */
/* Note that the entries in W are unchanged. */
i__4 = newlst;
for (k = newfst; k <= i__4; ++k) {
fudge = eps * 3. * (d__1 = work[wbegin + k -
1], abs(d__1));
work[wbegin + k - 1] -= tau;
fudge += eps * 4. * (d__1 = work[wbegin + k -
1], abs(d__1));
/* Fudge errors */
werr[wbegin + k - 1] += fudge;
/* Gaps are not fudged. Provided that WERR is small */
/* when eigenvalues are close, a zero gap indicates */
/* that a new representation is needed for resolving */
/* the cluster. A fudge could lead to a wrong decision */
/* of judging eigenvalues 'separated' which in */
/* reality are not. This could have a negative impact */
/* on the orthogonality of the computed eigenvectors. */
/* L116: */
}
++nclus;
k = newcls + (nclus << 1);
iwork[k - 1] = newfst;
iwork[k] = newlst;
} else {
*info = -2;
return 0;
}
} else {
/* Compute eigenvector of singleton */
iter = 0;
tol = log((doublereal) in) * 4. * eps;
k = newfst;
windex = wbegin + k - 1;
/* Computing MAX */
i__4 = windex - 1;
windmn = max(i__4,1);
/* Computing MIN */
i__4 = windex + 1;
windpl = min(i__4,*m);
lambda = work[windex];
++done;
/* Check if eigenvector computation is to be skipped */
if (windex < *dol || windex > *dou) {
eskip = TRUE_;
goto L125;
} else {
eskip = FALSE_;
}
left = work[windex] - werr[windex];
right = work[windex] + werr[windex];
indeig = indexw[windex];
/* Note that since we compute the eigenpairs for a child, */
/* all eigenvalue approximations are w.r.t the same shift. */
/* In this case, the entries in WORK should be used for */
/* computing the gaps since they exhibit even very small */
/* differences in the eigenvalues, as opposed to the */
/* entries in W which might "look" the same. */
if (k == 1) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VL, the formula */
/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
/* can lead to an overestimation of the left gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small left gap. */
/* Computing MAX */
d__1 = abs(left), d__2 = abs(right);
lgap = eps * max(d__1,d__2);
} else {
lgap = wgap[windmn];
}
if (k == im) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VU, the formula */
/* can lead to an overestimation of the right gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small right gap. */
/* Computing MAX */
d__1 = abs(left), d__2 = abs(right);
rgap = eps * max(d__1,d__2);
} else {
rgap = wgap[windex];
}
gap = min(lgap,rgap);
if (k == 1 || k == im) {
/* The eigenvector support can become wrong */
/* because significant entries could be cut off due to a */
/* large GAPTOL parameter in LAR1V. Prevent this. */
gaptol = 0.;
} else {
gaptol = gap * eps;
}
isupmn = in;
isupmx = 1;
/* Update WGAP so that it holds the minimum gap */
/* to the left or the right. This is crucial in the */
/* case where bisection is used to ensure that the */
/* eigenvalue is refined up to the required precision. */
/* The correct value is restored afterwards. */
savgap = wgap[windex];
wgap[windex] = gap;
/* We want to use the Rayleigh Quotient Correction */
/* as often as possible since it converges quadratically */
/* when we are close enough to the desired eigenvalue. */
/* However, the Rayleigh Quotient can have the wrong sign */
/* and lead us away from the desired eigenvalue. In this */
/* case, the best we can do is to use bisection. */
usedbs = FALSE_;
usedrq = FALSE_;
/* Bisection is initially turned off unless it is forced */
needbs = ! tryrqc;
L120:
/* Check if bisection should be used to refine eigenvalue */
if (needbs) {
/* Take the bisection as new iterate */
usedbs = TRUE_;
itmp1 = iwork[iindr + windex];
offset = indexw[wbegin] - 1;
d__1 = eps * 2.;
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &indeig, &indeig, &c_b5, &d__1, &
offset, &work[wbegin], &wgap[wbegin], &
werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &itmp1, &iinfo);
if (iinfo != 0) {
*info = -3;
return 0;
}
lambda = work[windex];
/* Reset twist index from inaccurate LAMBDA to */
/* force computation of true MINGMA */
iwork[iindr + windex] = 0;
}
/* Given LAMBDA, compute the eigenvector. */
L__1 = ! usedbs;
dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
ibegin], &work[indld + ibegin - 1], &work[
indlld + ibegin - 1], pivmin, &gaptol, &z__[
ibegin + windex * z_dim1], &L__1, &negcnt, &
ztz, &mingma, &iwork[iindr + windex], &isuppz[
(windex << 1) - 1], &nrminv, &resid, &rqcorr,
&work[indwrk]);
if (iter == 0) {
bstres = resid;
bstw = lambda;
} else if (resid < bstres) {
bstres = resid;
bstw = lambda;
}
/* Computing MIN */
i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
isupmn = min(i__4,i__5);
/* Computing MAX */
i__4 = isupmx, i__5 = isuppz[windex * 2];
isupmx = max(i__4,i__5);
++iter;
/* sin alpha <= |resid|/gap */
/* Note that both the residual and the gap are */
/* proportional to the matrix, so ||T|| doesn't play */
/* a role in the quotient */
/* Convergence test for Rayleigh-Quotient iteration */
/* (omitted when Bisection has been used) */
if (resid > tol * gap && abs(rqcorr) > rqtol * abs(
lambda) && ! usedbs) {
/* We need to check that the RQCORR update doesn't */
/* move the eigenvalue away from the desired one and */
/* towards a neighbor. -> protection with bisection */
if (indeig <= negcnt) {
/* The wanted eigenvalue lies to the left */
sgndef = -1.;
} else {
/* The wanted eigenvalue lies to the right */
sgndef = 1.;
}
/* We only use the RQCORR if it improves the */
/* the iterate reasonably. */
if (rqcorr * sgndef >= 0. && lambda + rqcorr <=
right && lambda + rqcorr >= left) {
usedrq = TRUE_;
/* Store new midpoint of bisection interval in WORK */
if (sgndef == 1.) {
/* The current LAMBDA is on the left of the true */
/* eigenvalue */
left = lambda;
/* We prefer to assume that the error estimate */
/* is correct. We could make the interval not */
/* as a bracket but to be modified if the RQCORR */
/* chooses to. In this case, the RIGHT side should */
/* be modified as follows: */
/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
} else {
/* The current LAMBDA is on the right of the true */
/* eigenvalue */
right = lambda;
/* See comment about assuming the error estimate is */
/* correct above. */
/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
}
work[windex] = (right + left) * .5;
/* Take RQCORR since it has the correct sign and */
/* improves the iterate reasonably */
lambda += rqcorr;
/* Update width of error interval */
werr[windex] = (right - left) * .5;
} else {
needbs = TRUE_;
}
if (right - left < rqtol * abs(lambda)) {
/* The eigenvalue is computed to bisection accuracy */
/* compute eigenvector and stop */
usedbs = TRUE_;
goto L120;
} else if (iter < 10) {
goto L120;
} else if (iter == 10) {
needbs = TRUE_;
goto L120;
} else {
*info = 5;
return 0;
}
} else {
stp2ii = FALSE_;
if (usedrq && usedbs && bstres <= resid) {
lambda = bstw;
stp2ii = TRUE_;
}
if (stp2ii) {
/* improve error angle by second step */
L__1 = ! usedbs;
dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
, &l[ibegin], &work[indld + ibegin -
1], &work[indlld + ibegin - 1],
pivmin, &gaptol, &z__[ibegin + windex
* z_dim1], &L__1, &negcnt, &ztz, &
mingma, &iwork[iindr + windex], &
isuppz[(windex << 1) - 1], &nrminv, &
resid, &rqcorr, &work[indwrk]);
}
work[windex] = lambda;
}
/* Compute FP-vector support w.r.t. whole matrix */
isuppz[(windex << 1) - 1] += oldien;
isuppz[windex * 2] += oldien;
zfrom = isuppz[(windex << 1) - 1];
zto = isuppz[windex * 2];
isupmn += oldien;
isupmx += oldien;
/* Ensure vector is ok if support in the RQI has changed */
if (isupmn < zfrom) {
i__4 = zfrom - 1;
for (ii = isupmn; ii <= i__4; ++ii) {
z__[ii + windex * z_dim1] = 0.;
/* L122: */
}
}
if (isupmx > zto) {
i__4 = isupmx;
for (ii = zto + 1; ii <= i__4; ++ii) {
z__[ii + windex * z_dim1] = 0.;
/* L123: */
}
}
i__4 = zto - zfrom + 1;
dscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
&c__1);
L125:
/* Update W */
w[windex] = lambda + sigma;
/* Recompute the gaps on the left and right */
/* But only allow them to become larger and not */
/* smaller (which can only happen through "bad" */
/* cancellation and doesn't reflect the theory */
/* where the initial gaps are underestimated due */
/* to WERR being too crude.) */
if (! eskip) {
if (k > 1) {
/* Computing MAX */
d__1 = wgap[windmn], d__2 = w[windex] - werr[
windex] - w[windmn] - werr[windmn];
wgap[windmn] = max(d__1,d__2);
}
if (windex < wend) {
/* Computing MAX */
d__1 = savgap, d__2 = w[windpl] - werr[windpl]
- w[windex] - werr[windex];
wgap[windex] = max(d__1,d__2);
}
}
++idone;
}
/* here ends the code for the current child */
L139:
/* Proceed to any remaining child nodes */
newfst = j + 1;
L140:
;
}
/* L150: */
}
++ndepth;
goto L40;
}
ibegin = iend + 1;
wbegin = wend + 1;
L170:
;
}
return 0;
/* End of DLARRV */
} /* dlarrv_ */

176
3rdparty/lapack/dlartg_custom.c vendored
View File

@ -1,176 +0,0 @@
#include "clapack.h"
/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs,
doublereal *sn, doublereal *r__)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
integer i__;
doublereal f1, g1, eps, scale;
integer count;
static doublereal safmn2, safmx2;
static doublereal safmin;
static volatile logical FIRST = TRUE_;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARTG generate a plane rotation so that */
/* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */
/* [ -SN CS ] [ G ] [ 0 ] */
/* This is a slower, more accurate version of the BLAS1 routine DROTG, */
/* with the following other differences: */
/* F and G are unchanged on return. */
/* If G=0, then CS=1 and SN=0. */
/* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */
/* floating point operations (saves work in DBDSQR when */
/* there are zeros on the diagonal). */
/* If F exceeds G in magnitude, CS will be positive. */
/* Arguments */
/* ========= */
/* F (input) DOUBLE PRECISION */
/* The first component of vector to be rotated. */
/* G (input) DOUBLE PRECISION */
/* The second component of vector to be rotated. */
/* CS (output) DOUBLE PRECISION */
/* The cosine of the rotation. */
/* SN (output) DOUBLE PRECISION */
/* The sine of the rotation. */
/* R (output) DOUBLE PRECISION */
/* The nonzero component of the rotated vector. */
/* This version has a few statements commented out for thread safety */
/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* LOGICAL FIRST */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
/* .. */
/* .. Data statements .. */
/* DATA FIRST / .TRUE. / */
/* .. */
/* .. Executable Statements .. */
if( FIRST )
{
safmin = dlamch_("S");
eps = dlamch_("E");
d__1 = dlamch_("B");
i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.);
safmn2 = pow_di(&d__1, &i__1);
safmx2 = 1. / safmn2;
FIRST = FALSE_;
}
if (*g == 0.) {
*cs = 1.;
*sn = 0.;
*r__ = *f;
} else if (*f == 0.) {
*cs = 0.;
*sn = 1.;
*r__ = *g;
} else {
f1 = *f;
g1 = *g;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale >= safmx2) {
count = 0;
L10:
++count;
f1 *= safmn2;
g1 *= safmn2;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale >= safmx2) {
goto L10;
}
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmx2;
/* L20: */
}
} else if (scale <= safmn2) {
count = 0;
L30:
++count;
f1 *= safmx2;
g1 *= safmx2;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale <= safmn2) {
goto L30;
}
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmn2;
/* L40: */
}
} else {
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
}
if (abs(*f) > abs(*g) && *cs < 0.) {
*cs = -(*cs);
*sn = -(*sn);
*r__ = -(*r__);
}
}
return 0;
/* End of DLARTG */
} /* dlartg_ */

192
3rdparty/lapack/dlaruv.c vendored
View File

@ -1,192 +0,0 @@
/* dlaruv.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 dlaruv_(integer *iseed, integer *n, doublereal *x)
{
/* Initialized data */
static integer mm[512] /* was [128][4] */ = { 494,2637,255,2008,1253,
3344,4084,1739,3143,3468,688,1657,1238,3166,1292,3422,1270,2016,
154,2862,697,1706,491,931,1444,444,3577,3944,2184,1661,3482,657,
3023,3618,1267,1828,164,3798,3087,2400,2870,3876,1905,1593,1797,
1234,3460,328,2861,1950,617,2070,3331,769,1558,2412,2800,189,287,
2045,1227,2838,209,2770,3654,3993,192,2253,3491,2889,2857,2094,
1818,688,1407,634,3231,815,3524,1914,516,164,303,2144,3480,119,
3357,837,2826,2332,2089,3780,1700,3712,150,2000,3375,1621,3090,
3765,1149,3146,33,3082,2741,359,3316,1749,185,2784,2202,2199,1364,
1244,2020,3160,2785,2772,1217,1822,1245,2252,3904,2774,997,2573,
1148,545,322,789,1440,752,2859,123,1848,643,2405,2638,2344,46,
3814,913,3649,339,3808,822,2832,3078,3633,2970,637,2249,2081,4019,
1478,242,481,2075,4058,622,3376,812,234,641,4005,1122,3135,2640,
2302,40,1832,2247,2034,2637,1287,1691,496,1597,2394,2584,1843,336,
1472,2407,433,2096,1761,2810,566,442,41,1238,1086,603,840,3168,
1499,1084,3438,2408,1589,2391,288,26,512,1456,171,1677,2657,2270,
2587,2961,1970,1817,676,1410,3723,2803,3185,184,663,499,3784,1631,
1925,3912,1398,1349,1441,2224,2411,1907,3192,2786,382,37,759,2948,
1862,3802,2423,2051,2295,1332,1832,2405,3638,3661,327,3660,716,
1842,3987,1368,1848,2366,2508,3754,1766,3572,2893,307,1297,3966,
758,2598,3406,2922,1038,2934,2091,2451,1580,1958,2055,1507,1078,
3273,17,854,2916,3971,2889,3831,2621,1541,893,736,3992,787,2125,
2364,2460,257,1574,3912,1216,3248,3401,2124,2762,149,2245,166,466,
4018,1399,190,2879,153,2320,18,712,2159,2318,2091,3443,1510,449,
1956,2201,3137,3399,1321,2271,3667,2703,629,2365,2431,1113,3922,
2554,184,2099,3228,4012,1921,3452,3901,572,3309,3171,817,3039,
1696,1256,3715,2077,3019,1497,1101,717,51,981,1978,1813,3881,76,
3846,3694,1682,124,1660,3997,479,1141,886,3514,1301,3604,1888,
1836,1990,2058,692,1194,20,3285,2046,2107,3508,3525,3801,2549,
1145,2253,305,3301,1065,3133,2913,3285,1241,1197,3729,2501,1673,
541,2753,949,2361,1165,4081,2725,3305,3069,3617,3733,409,2157,
1361,3973,1865,2525,1409,3445,3577,77,3761,2149,1449,3005,225,85,
3673,3117,3089,1349,2057,413,65,1845,697,3085,3441,1573,3689,2941,
929,533,2841,4077,721,2821,2249,2397,2817,245,1913,1997,3121,997,
1833,2877,1633,981,2009,941,2449,197,2441,285,1473,2741,3129,909,
2801,421,4073,2813,2337,1429,1177,1901,81,1669,2633,2269,129,1141,
249,3917,2481,3941,2217,2749,3041,1877,345,2861,1809,3141,2825,
157,2881,3637,1465,2829,2161,3365,361,2685,3745,2325,3609,3821,
3537,517,3017,2141,1537 };
/* System generated locals */
integer i__1;
/* Local variables */
integer i__, i1, i2, i3, i4, it1, it2, it3, it4;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARUV returns a vector of n random real numbers from a uniform (0,1) */
/* distribution (n <= 128). */
/* This is an auxiliary routine called by DLARNV and ZLARNV. */
/* Arguments */
/* ========= */
/* 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. N <= 128. */
/* X (output) DOUBLE PRECISION array, dimension (N) */
/* The generated random numbers. */
/* Further Details */
/* =============== */
/* This routine uses a multiplicative congruential method with modulus */
/* 2**48 and multiplier 33952834046453 (see G.S.Fishman, */
/* 'Multiplicative congruential random number generators with modulus */
/* 2**b: an exhaustive analysis for b = 32 and a partial analysis for */
/* b = 48', Math. Comp. 189, pp 331-344, 1990). */
/* 48-bit integers are stored in 4 integer array elements with 12 bits */
/* per element. Hence the routine is portable across machines with */
/* integers of 32 bits or more. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iseed;
--x;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
i1 = iseed[1];
i2 = iseed[2];
i3 = iseed[3];
i4 = iseed[4];
i__1 = min(*n,128);
for (i__ = 1; i__ <= i__1; ++i__) {
L20:
/* Multiply the seed by i-th power of the multiplier modulo 2**48 */
it4 = i4 * mm[i__ + 383];
it3 = it4 / 4096;
it4 -= it3 << 12;
it3 = it3 + i3 * mm[i__ + 383] + i4 * mm[i__ + 255];
it2 = it3 / 4096;
it3 -= it2 << 12;
it2 = it2 + i2 * mm[i__ + 383] + i3 * mm[i__ + 255] + i4 * mm[i__ +
127];
it1 = it2 / 4096;
it2 -= it1 << 12;
it1 = it1 + i1 * mm[i__ + 383] + i2 * mm[i__ + 255] + i3 * mm[i__ +
127] + i4 * mm[i__ - 1];
it1 %= 4096;
/* Convert 48-bit integer to a real number in the interval (0,1) */
x[i__] = ((doublereal) it1 + ((doublereal) it2 + ((doublereal) it3 + (
doublereal) it4 * 2.44140625e-4) * 2.44140625e-4) *
2.44140625e-4) * 2.44140625e-4;
if (x[i__] == 1.) {
/* If a real number has n bits of precision, and the first */
/* n bits of the 48-bit integer above happen to be all 1 (which */
/* will occur about once every 2**n calls), then X( I ) will */
/* be rounded to exactly 1.0. */
/* Since X( I ) is not supposed to return exactly 0.0 or 1.0, */
/* the statistically correct thing to do in this situation is */
/* simply to iterate again. */
/* N.B. the case X( I ) = 0.0 should not be possible. */
i1 += 2;
i2 += 2;
i3 += 2;
i4 += 2;
goto L20;
}
/* L10: */
}
/* Return final value of seed */
iseed[1] = it1;
iseed[2] = it2;
iseed[3] = it3;
iseed[4] = it4;
return 0;
/* End of DLARUV */
} /* dlaruv_ */

144
3rdparty/lapack/dlas2.c vendored
View File

@ -1,144 +0,0 @@
/* dlas2.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 dlas2_(doublereal *f, doublereal *g, doublereal *h__,
doublereal *ssmin, doublereal *ssmax)
{
/* System generated locals */
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal c__, fa, ga, ha, as, at, au, fhmn, fhmx;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAS2 computes the singular values of the 2-by-2 matrix */
/* [ F G ] */
/* [ 0 H ]. */
/* On return, SSMIN is the smaller singular value and SSMAX is the */
/* larger singular value. */
/* Arguments */
/* ========= */
/* F (input) DOUBLE PRECISION */
/* The (1,1) element of the 2-by-2 matrix. */
/* G (input) DOUBLE PRECISION */
/* The (1,2) element of the 2-by-2 matrix. */
/* H (input) DOUBLE PRECISION */
/* The (2,2) element of the 2-by-2 matrix. */
/* SSMIN (output) DOUBLE PRECISION */
/* The smaller singular value. */
/* SSMAX (output) DOUBLE PRECISION */
/* The larger singular value. */
/* Further Details */
/* =============== */
/* Barring over/underflow, all output quantities are correct to within */
/* a few units in the last place (ulps), even in the absence of a guard */
/* digit in addition/subtraction. */
/* In IEEE arithmetic, the code works correctly if one matrix element is */
/* infinite. */
/* Overflow will not occur unless the largest singular value itself */
/* overflows, or is within a few ulps of overflow. (On machines with */
/* partial overflow, like the Cray, overflow may occur if the largest */
/* singular value is within a factor of 2 of overflow.) */
/* Underflow is harmless if underflow is gradual. Otherwise, results */
/* may correspond to a matrix modified by perturbations of size near */
/* the underflow threshold. */
/* ==================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
fa = abs(*f);
ga = abs(*g);
ha = abs(*h__);
fhmn = min(fa,ha);
fhmx = max(fa,ha);
if (fhmn == 0.) {
*ssmin = 0.;
if (fhmx == 0.) {
*ssmax = ga;
} else {
/* Computing 2nd power */
d__1 = min(fhmx,ga) / max(fhmx,ga);
*ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.);
}
} else {
if (ga < fhmx) {
as = fhmn / fhmx + 1.;
at = (fhmx - fhmn) / fhmx;
/* Computing 2nd power */
d__1 = ga / fhmx;
au = d__1 * d__1;
c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au));
*ssmin = fhmn * c__;
*ssmax = fhmx / c__;
} else {
au = fhmx / ga;
if (au == 0.) {
/* Avoid possible harmful underflow if exponent range */
/* asymmetric (true SSMIN may not underflow even if */
/* AU underflows) */
*ssmin = fhmn * fhmx / ga;
*ssmax = ga;
} else {
as = fhmn / fhmx + 1.;
at = (fhmx - fhmn) / fhmx;
/* Computing 2nd power */
d__1 = as * au;
/* Computing 2nd power */
d__2 = at * au;
c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.));
*ssmin = fhmn * c__ * au;
*ssmin += *ssmin;
*ssmax = ga / (c__ + c__);
}
}
}
return 0;
/* End of DLAS2 */
} /* dlas2_ */

354
3rdparty/lapack/dlascl.c vendored
View File

@ -1,354 +0,0 @@
/* dlascl.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 dlascl_(char *type__, integer *kl, integer *ku,
doublereal *cfrom, doublereal *cto, integer *m, integer *n,
doublereal *a, integer *lda, 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, k1, k2, k3, k4;
doublereal mul, cto1;
logical done;
doublereal ctoc;
extern logical lsame_(char *, char *);
integer itype;
doublereal cfrom1;
extern doublereal dlamch_(char *);
doublereal cfromc;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASCL multiplies the M by N real matrix A by the real scalar */
/* CTO/CFROM. This is done without over/underflow as long as the final */
/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
/* A may be full, upper triangular, lower triangular, upper Hessenberg, */
/* or banded. */
/* Arguments */
/* ========= */
/* TYPE (input) CHARACTER*1 */
/* TYPE indices the storage type of the input matrix. */
/* = 'G': A is a full matrix. */
/* = 'L': A is a lower triangular matrix. */
/* = 'U': A is an upper triangular matrix. */
/* = 'H': A is an upper Hessenberg matrix. */
/* = 'B': A is a symmetric band matrix with lower bandwidth KL */
/* and upper bandwidth KU and with the only the lower */
/* half stored. */
/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */
/* and upper bandwidth KU and with the only the upper */
/* half stored. */
/* = 'Z': A is a band matrix with lower bandwidth KL and upper */
/* bandwidth KU. */
/* KL (input) INTEGER */
/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
/* 'Q' or 'Z'. */
/* KU (input) INTEGER */
/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
/* 'Q' or 'Z'. */
/* CFROM (input) DOUBLE PRECISION */
/* CTO (input) DOUBLE PRECISION */
/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
/* without over/underflow if the final result CTO*A(I,J)/CFROM */
/* can be represented without over/underflow. CFROM must be */
/* nonzero. */
/* 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) */
/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
/* storage type. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* INFO (output) INTEGER */
/* 0 - successful exit */
/* <0 - if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
if (lsame_(type__, "G")) {
itype = 0;
} else if (lsame_(type__, "L")) {
itype = 1;
} else if (lsame_(type__, "U")) {
itype = 2;
} else if (lsame_(type__, "H")) {
itype = 3;
} else if (lsame_(type__, "B")) {
itype = 4;
} else if (lsame_(type__, "Q")) {
itype = 5;
} else if (lsame_(type__, "Z")) {
itype = 6;
} else {
itype = -1;
}
if (itype == -1) {
*info = -1;
} else if (*cfrom == 0. || disnan_(cfrom)) {
*info = -4;
} else if (disnan_(cto)) {
*info = -5;
} else if (*m < 0) {
*info = -6;
} else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
*info = -7;
} else if (itype <= 3 && *lda < max(1,*m)) {
*info = -9;
} else if (itype >= 4) {
/* Computing MAX */
i__1 = *m - 1;
if (*kl < 0 || *kl > max(i__1,0)) {
*info = -2;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = *n - 1;
if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
*kl != *ku) {
*info = -3;
} else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
*info = -9;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASCL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S");
bignum = 1. / smlnum;
cfromc = *cfrom;
ctoc = *cto;
L10:
cfrom1 = cfromc * smlnum;
if (cfrom1 == cfromc) {
/* CFROMC is an inf. Multiply by a correctly signed zero for */
/* finite CTOC, or a NaN if CTOC is infinite. */
mul = ctoc / cfromc;
done = TRUE_;
cto1 = ctoc;
} else {
cto1 = ctoc / bignum;
if (cto1 == ctoc) {
/* CTOC is either 0 or an inf. In both cases, CTOC itself */
/* serves as the correct multiplication factor. */
mul = ctoc;
done = TRUE_;
cfromc = 1.;
} else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
mul = smlnum;
done = FALSE_;
cfromc = cfrom1;
} else if (abs(cto1) > abs(cfromc)) {
mul = bignum;
done = FALSE_;
ctoc = cto1;
} else {
mul = ctoc / cfromc;
done = TRUE_;
}
}
if (itype == 0) {
/* Full matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L20: */
}
/* L30: */
}
} else if (itype == 1) {
/* Lower triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L40: */
}
/* L50: */
}
} else if (itype == 2) {
/* Upper triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L60: */
}
/* L70: */
}
} else if (itype == 3) {
/* Upper Hessenberg matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j + 1;
i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L80: */
}
/* L90: */
}
} else if (itype == 4) {
/* Lower half of a symmetric band matrix */
k3 = *kl + 1;
k4 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = k3, i__4 = k4 - j;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L100: */
}
/* L110: */
}
} else if (itype == 5) {
/* Upper half of a symmetric band matrix */
k1 = *ku + 2;
k3 = *ku + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = k1 - j;
i__3 = k3;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L120: */
}
/* L130: */
}
} else if (itype == 6) {
/* Band matrix */
k1 = *kl + *ku + 2;
k2 = *kl + 1;
k3 = (*kl << 1) + *ku + 1;
k4 = *kl + *ku + 1 + *m;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = k1 - j;
/* Computing MIN */
i__4 = k3, i__5 = k4 - j;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L140: */
}
/* L150: */
}
}
if (! done) {
goto L10;
}
return 0;
/* End of DLASCL */
} /* dlascl_ */

291
3rdparty/lapack/dlasd0.c vendored
View File

@ -1,291 +0,0 @@
/* dlasd0.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__0 = 0;
static integer c__2 = 2;
/* Subroutine */ int dlasd0_(integer *n, integer *sqre, doublereal *d__,
doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *
ldvt, integer *smlsiz, integer *iwork, doublereal *work, integer *
info)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Local variables */
integer i__, j, m, i1, ic, lf, nd, ll, nl, nr, im1, ncc, nlf, nrf, iwk,
lvl, ndb1, nlp1, nrp1;
doublereal beta;
integer idxq, nlvl;
doublereal alpha;
integer inode, ndiml, idxqc, ndimr, itemp, sqrei;
extern /* Subroutine */ int dlasd1_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *, doublereal *,
integer *), dlasdq_(char *, integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *), dlasdt_(integer *, integer *,
integer *, integer *, integer *, integer *, integer *), xerbla_(
char *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Using a divide and conquer approach, DLASD0 computes the singular */
/* value decomposition (SVD) of a real upper bidiagonal N-by-M */
/* matrix B with diagonal D and offdiagonal E, where M = N + SQRE. */
/* The algorithm computes orthogonal matrices U and VT such that */
/* B = U * S * VT. The singular values S are overwritten on D. */
/* A related subroutine, DLASDA, computes only the singular values, */
/* and optionally, the singular vectors in compact form. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* On entry, the row dimension of the upper bidiagonal matrix. */
/* This is also the dimension of the main diagonal array D. */
/* SQRE (input) INTEGER */
/* Specifies the column dimension of the bidiagonal matrix. */
/* = 0: The bidiagonal matrix has column dimension M = N; */
/* = 1: The bidiagonal matrix has column dimension M = N+1; */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry D contains the main diagonal of the bidiagonal */
/* matrix. */
/* On exit D, if INFO = 0, contains its singular values. */
/* E (input) DOUBLE PRECISION array, dimension (M-1) */
/* Contains the subdiagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N) */
/* On exit, U contains the left singular vectors. */
/* LDU (input) INTEGER */
/* On entry, leading dimension of U. */
/* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M) */
/* On exit, VT' contains the right singular vectors. */
/* LDVT (input) INTEGER */
/* On entry, leading dimension of VT. */
/* SMLSIZ (input) INTEGER */
/* On entry, maximum size of the subproblems at the */
/* bottom of the computation tree. */
/* IWORK (workspace) INTEGER work array. */
/* Dimension must be at least (8 * N) */
/* WORK (workspace) DOUBLE PRECISION work array. */
/* Dimension must be at least (3 * M**2 + 2 * M) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. 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;
--iwork;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*sqre < 0 || *sqre > 1) {
*info = -2;
}
m = *n + *sqre;
if (*ldu < *n) {
*info = -6;
} else if (*ldvt < m) {
*info = -8;
} else if (*smlsiz < 3) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD0", &i__1);
return 0;
}
/* If the input matrix is too small, call DLASDQ to find the SVD. */
if (*n <= *smlsiz) {
dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset],
ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], info);
return 0;
}
/* Set up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
idxq = ndimr + *n;
iwk = idxq + *n;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* For the nodes on bottom level of the tree, solve */
/* their subproblems by DLASDQ. */
ndb1 = (nd + 1) / 2;
ncc = 0;
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];
nlp1 = nl + 1;
nr = iwork[ndimr + i1];
nrp1 = nr + 1;
nlf = ic - nl;
nrf = ic + 1;
sqrei = 1;
dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[
nlf + nlf * vt_dim1], ldvt, &u[nlf + nlf * u_dim1], ldu, &u[
nlf + nlf * u_dim1], ldu, &work[1], info);
if (*info != 0) {
return 0;
}
itemp = idxq + nlf - 2;
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
iwork[itemp + j] = j;
/* L10: */
}
if (i__ == nd) {
sqrei = *sqre;
} else {
sqrei = 1;
}
nrp1 = nr + sqrei;
dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[
nrf + nrf * vt_dim1], ldvt, &u[nrf + nrf * u_dim1], ldu, &u[
nrf + nrf * u_dim1], ldu, &work[1], info);
if (*info != 0) {
return 0;
}
itemp = idxq + ic;
i__2 = nr;
for (j = 1; j <= i__2; ++j) {
iwork[itemp + j - 1] = j;
/* L20: */
}
/* L30: */
}
/* Now conquer each subproblem bottom-up. */
for (lvl = nlvl; lvl >= 1; --lvl) {
/* 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;
if (*sqre == 0 && i__ == ll) {
sqrei = *sqre;
} else {
sqrei = 1;
}
idxqc = idxq + nlf - 1;
alpha = d__[ic];
beta = e[ic];
dlasd1_(&nl, &nr, &sqrei, &d__[nlf], &alpha, &beta, &u[nlf + nlf *
u_dim1], ldu, &vt[nlf + nlf * vt_dim1], ldvt, &iwork[
idxqc], &iwork[iwk], &work[1], info);
if (*info != 0) {
return 0;
}
/* L40: */
}
/* L50: */
}
return 0;
/* End of DLASD0 */
} /* dlasd0_ */

288
3rdparty/lapack/dlasd1.c vendored
View File

@ -1,288 +0,0 @@
/* dlasd1.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__0 = 0;
static doublereal c_b7 = 1.;
static integer c__1 = 1;
static integer c_n1 = -1;
/* Subroutine */ int dlasd1_(integer *nl, integer *nr, integer *sqre,
doublereal *d__, doublereal *alpha, doublereal *beta, doublereal *u,
integer *ldu, doublereal *vt, integer *ldvt, integer *idxq, integer *
iwork, doublereal *work, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc,
idxp, ldvt2;
extern /* Subroutine */ int dlasd2_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlasd3_(
integer *, integer *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *),
dlamrg_(integer *, integer *, doublereal *, integer *, integer *,
integer *);
integer isigma;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal orgnrm;
integer coltyp;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, */
/* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. */
/* A related subroutine DLASD7 handles the case in which the singular */
/* values (and the singular vectors in factored form) are desired. */
/* DLASD1 computes the SVD as follows: */
/* ( D1(in) 0 0 0 ) */
/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */
/* ( 0 0 D2(in) 0 ) */
/* = U(out) * ( D(out) 0) * VT(out) */
/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */
/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */
/* elsewhere; and the entry b is empty if SQRE = 0. */
/* The left singular vectors of the original matrix are stored in U, and */
/* the transpose of the right singular vectors are stored in VT, and the */
/* singular values are in D. The algorithm consists of three stages: */
/* The first stage consists of deflating the size of the problem */
/* when there are multiple singular values or when there are zeros 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 DLASD2. */
/* The second stage consists of calculating the updated */
/* singular values. This is done by finding the square roots of the */
/* roots of the secular equation via the routine DLASD4 (as called */
/* by DLASD3). This routine also calculates the singular vectors of */
/* the current problem. */
/* The final stage consists of computing the updated singular vectors */
/* directly using the updated singular values. The singular vectors */
/* for the current problem are multiplied with the singular vectors */
/* from the overall problem. */
/* Arguments */
/* ========= */
/* 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. */
/* D (input/output) DOUBLE PRECISION array, */
/* dimension (N = NL+NR+1). */
/* On entry D(1:NL,1:NL) contains the singular values of the */
/* upper block; and D(NL+2:N) contains the singular values of */
/* the lower block. On exit D(1:N) contains the singular values */
/* of the modified matrix. */
/* ALPHA (input/output) DOUBLE PRECISION */
/* Contains the diagonal element associated with the added row. */
/* BETA (input/output) DOUBLE PRECISION */
/* Contains the off-diagonal element associated with the added */
/* row. */
/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */
/* On entry U(1:NL, 1:NL) contains the left singular vectors of */
/* the upper block; U(NL+2:N, NL+2:N) contains the left singular */
/* vectors of the lower block. On exit U contains the left */
/* singular vectors of the bidiagonal matrix. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max( 1, N ). */
/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */
/* where M = N + SQRE. */
/* On entry VT(1:NL+1, 1:NL+1)' contains the right singular */
/* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains */
/* the right singular vectors of the lower block. On exit */
/* VT' contains the right singular vectors of the */
/* bidiagonal matrix. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= max( 1, M ). */
/* IDXQ (output) INTEGER array, dimension(N) */
/* This contains the permutation which will reintegrate the */
/* subproblem just solved back into sorted order, i.e. */
/* D( IDXQ( I = 1, N ) ) will be in ascending order. */
/* IWORK (workspace) INTEGER array, dimension( 4 * N ) */
/* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, 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__;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--idxq;
--iwork;
--work;
/* Function Body */
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre < 0 || *sqre > 1) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD1", &i__1);
return 0;
}
n = *nl + *nr + 1;
m = n + *sqre;
/* 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 DLASD2 and DLASD3. */
ldu2 = n;
ldvt2 = m;
iz = 1;
isigma = iz + m;
iu2 = isigma + n;
ivt2 = iu2 + ldu2 * n;
iq = ivt2 + ldvt2 * m;
idx = 1;
idxc = idx + n;
coltyp = idxc + n;
idxp = coltyp + n;
/* Scale. */
/* Computing MAX */
d__1 = abs(*alpha), d__2 = abs(*beta);
orgnrm = max(d__1,d__2);
d__[*nl + 1] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) > orgnrm) {
orgnrm = (d__1 = d__[i__], abs(d__1));
}
/* L10: */
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info);
*alpha /= orgnrm;
*beta /= orgnrm;
/* Deflate singular values. */
dlasd2_(nl, nr, sqre, &k, &d__[1], &work[iz], alpha, beta, &u[u_offset],
ldu, &vt[vt_offset], ldvt, &work[isigma], &work[iu2], &ldu2, &
work[ivt2], &ldvt2, &iwork[idxp], &iwork[idx], &iwork[idxc], &
idxq[1], &iwork[coltyp], info);
/* Solve Secular Equation and update singular vectors. */
ldq = k;
dlasd3_(nl, nr, sqre, &k, &d__[1], &work[iq], &ldq, &work[isigma], &u[
u_offset], ldu, &work[iu2], &ldu2, &vt[vt_offset], ldvt, &work[
ivt2], &ldvt2, &iwork[idxc], &iwork[coltyp], &work[iz], info);
if (*info != 0) {
return 0;
}
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info);
/* Prepare the IDXQ sorting permutation. */
n1 = k;
n2 = n - k;
dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
return 0;
/* End of DLASD1 */
} /* dlasd1_ */

609
3rdparty/lapack/dlasd2.c vendored
View File

@ -1,609 +0,0 @@
/* dlasd2.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_b30 = 0.;
/* Subroutine */ int dlasd2_(integer *nl, integer *nr, integer *sqre, integer
*k, doublereal *d__, doublereal *z__, doublereal *alpha, doublereal *
beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt,
doublereal *dsigma, doublereal *u2, integer *ldu2, doublereal *vt2,
integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *
idxq, integer *coltyp, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset,
vt2_dim1, vt2_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal c__;
integer i__, j, m, n;
doublereal s;
integer k2;
doublereal z1;
integer ct, jp;
doublereal eps, tau, tol;
integer psm[4], nlp1, nlp2, idxi, idxj;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer ctot[4], idxjp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer jprev;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
doublereal hlftol;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD2 merges the two sets of singular values 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 */
/* singular values 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. */
/* DLASD2 is called from DLASD1. */
/* Arguments */
/* ========= */
/* 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 N = NL + NR + 1 rows and */
/* M = N + SQRE >= N columns. */
/* K (output) INTEGER */
/* Contains the dimension of the non-deflated matrix, */
/* This is the order of the related secular equation. 1 <= K <=N. */
/* D (input/output) DOUBLE PRECISION array, dimension(N) */
/* On entry D contains the singular values of the two submatrices */
/* to be combined. On exit D contains the trailing (N-K) updated */
/* singular values (those which were deflated) sorted into */
/* increasing order. */
/* Z (output) DOUBLE PRECISION array, dimension(N) */
/* On exit Z contains the updating row vector in the secular */
/* equation. */
/* ALPHA (input) DOUBLE PRECISION */
/* Contains the diagonal element associated with the added row. */
/* BETA (input) DOUBLE PRECISION */
/* Contains the off-diagonal element associated with the added */
/* row. */
/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */
/* On entry U contains the left singular vectors of two */
/* submatrices in the two square blocks with corners at (1,1), */
/* (NL, NL), and (NL+2, NL+2), (N,N). */
/* On exit U contains the trailing (N-K) updated left singular */
/* vectors (those which were deflated) in its last N-K columns. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= N. */
/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */
/* On entry VT' contains the right singular vectors of two */
/* submatrices in the two square blocks with corners at (1,1), */
/* (NL+1, NL+1), and (NL+2, NL+2), (M,M). */
/* On exit VT' contains the trailing (N-K) updated right singular */
/* vectors (those which were deflated) in its last N-K columns. */
/* In case SQRE =1, the last row of VT spans the right null */
/* space. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= M. */
/* DSIGMA (output) DOUBLE PRECISION array, dimension (N) */
/* Contains a copy of the diagonal elements (K-1 singular values */
/* and one zero) in the secular equation. */
/* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N) */
/* Contains a copy of the first K-1 left singular vectors which */
/* will be used by DLASD3 in a matrix multiply (DGEMM) to solve */
/* for the new left singular vectors. U2 is arranged into four */
/* blocks. The first block contains a column with 1 at NL+1 and */
/* zero everywhere else; the second block contains non-zero */
/* entries only at and above NL; the third contains non-zero */
/* entries only below NL+1; and the fourth is dense. */
/* LDU2 (input) INTEGER */
/* The leading dimension of the array U2. LDU2 >= N. */
/* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N) */
/* VT2' contains a copy of the first K right singular vectors */
/* which will be used by DLASD3 in a matrix multiply (DGEMM) to */
/* solve for the new right singular vectors. VT2 is arranged into */
/* three blocks. The first block contains a row that corresponds */
/* to the special 0 diagonal element in SIGMA; the second block */
/* contains non-zeros only at and before NL +1; the third block */
/* contains non-zeros only at and after NL +2. */
/* LDVT2 (input) INTEGER */
/* The leading dimension of the array VT2. LDVT2 >= M. */
/* IDXP (workspace) INTEGER array dimension(N) */
/* This will contain the permutation used to place deflated */
/* values of D at the end of the array. On output IDXP(2:K) */
/* points to the nondeflated D-values and IDXP(K+1:N) */
/* points to the deflated singular values. */
/* IDX (workspace) INTEGER array dimension(N) */
/* This will contain the permutation used to sort the contents of */
/* D into ascending order. */
/* IDXC (output) INTEGER array dimension(N) */
/* This will contain the permutation used to arrange the columns */
/* of the deflated U matrix into three groups: the first group */
/* contains non-zero entries only at and above NL, the second */
/* contains non-zero entries only below NL+2, and the third is */
/* dense. */
/* IDXQ (input/output) INTEGER array dimension(N) */
/* This contains the permutation which separately sorts the two */
/* sub-problems in D into ascending order. Note that entries in */
/* the first hlaf of this permutation must first be moved one */
/* position backward; and entries in the second half */
/* must first have NL+1 added to their values. */
/* COLTYP (workspace/output) INTEGER array dimension(N) */
/* As workspace, this will contain a label which will indicate */
/* which of the following types a column in the U2 matrix or a */
/* row in the VT2 matrix is: */
/* 1 : non-zero in the upper half only */
/* 2 : non-zero in the lower half only */
/* 3 : dense */
/* 4 : deflated */
/* On exit, it is an array of dimension 4, with COLTYP(I) being */
/* the dimension of the I-th type columns. */
/* 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 Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--dsigma;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxp;
--idx;
--idxc;
--idxq;
--coltyp;
/* Function Body */
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre != 1 && *sqre != 0) {
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
if (*ldu < n) {
*info = -10;
} else if (*ldvt < m) {
*info = -12;
} else if (*ldu2 < n) {
*info = -15;
} else if (*ldvt2 < m) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD2", &i__1);
return 0;
}
nlp1 = *nl + 1;
nlp2 = *nl + 2;
/* Generate the first part of the vector Z; and move the singular */
/* values in the first part of D one position backward. */
z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
z__[1] = z1;
for (i__ = *nl; i__ >= 1; --i__) {
z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1;
/* L10: */
}
/* Generate the second part of the vector Z. */
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
/* L20: */
}
/* Initialize some reference arrays. */
i__1 = nlp1;
for (i__ = 2; i__ <= i__1; ++i__) {
coltyp[i__] = 1;
/* L30: */
}
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
coltyp[i__] = 2;
/* L40: */
}
/* Sort the singular values into increasing order */
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
idxq[i__] += nlp1;
/* L50: */
}
/* DSIGMA, IDXC, IDXC, and the first column of U2 */
/* are used as storage space. */
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
dsigma[i__] = d__[idxq[i__]];
u2[i__ + u2_dim1] = z__[idxq[i__]];
idxc[i__] = coltyp[idxq[i__]];
/* L60: */
}
dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
idxi = idx[i__] + 1;
d__[i__] = dsigma[idxi];
z__[i__] = u2[idxi + u2_dim1];
coltyp[i__] = idxc[idxi];
/* L70: */
}
/* Calculate the allowable deflation tolerance */
eps = dlamch_("Epsilon");
/* Computing MAX */
d__1 = abs(*alpha), d__2 = abs(*beta);
tol = max(d__1,d__2);
/* Computing MAX */
d__2 = (d__1 = d__[n], abs(d__1));
tol = eps * 8. * max(d__2,tol);
/* There are 2 kinds of deflation -- first a value in the z-vector */
/* is small, second two (or more) singular values are very close */
/* together (their difference is small). */
/* If the value in the z-vector is small, we simply permute the */
/* array so that the corresponding singular value is moved to the */
/* end. */
/* If two values in the D-vector are close, we perform a two-sided */
/* rotation designed to make one of the corresponding z-vector */
/* entries zero, and then permute the array so that the deflated */
/* singular value is moved to the end. */
/* If there are multiple singular values then the problem deflates. */
/* Here the number of equal singular values are found. As each equal */
/* singular value is found, an elementary reflector is computed to */
/* rotate the corresponding singular subspace so that the */
/* corresponding components of Z are zero in this new basis. */
*k = 1;
k2 = n + 1;
i__1 = n;
for (j = 2; j <= i__1; ++j) {
if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
if (j == n) {
goto L120;
}
} else {
jprev = j;
goto L90;
}
/* L80: */
}
L90:
j = jprev;
L100:
++j;
if (j > n) {
goto L110;
}
if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
} else {
/* Check if singular values are close enough to allow deflation. */
if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
/* Deflation is possible. */
s = z__[jprev];
c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = dlapy2_(&c__, &s);
c__ /= tau;
s = -s / tau;
z__[j] = tau;
z__[jprev] = 0.;
/* Apply back the Givens rotation to the left and right */
/* singular vector matrices. */
idxjp = idxq[idx[jprev] + 1];
idxj = idxq[idx[j] + 1];
if (idxjp <= nlp1) {
--idxjp;
}
if (idxj <= nlp1) {
--idxj;
}
drot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], &
c__1, &c__, &s);
drot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, &
c__, &s);
if (coltyp[j] != coltyp[jprev]) {
coltyp[j] = 3;
}
coltyp[jprev] = 4;
--k2;
idxp[k2] = jprev;
jprev = j;
} else {
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
jprev = j;
}
}
goto L100;
L110:
/* Record the last singular value. */
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
L120:
/* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four groups of uniform structure (although one or more of these */
/* groups may be empty). */
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
/* L130: */
}
i__1 = n;
for (j = 2; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
/* L140: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 2;
psm[1] = ctot[0] + 2;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
/* Fill out the IDXC 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, starting from the */
/* second column. This applies similarly to the rows of VT. */
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
ct = coltyp[jp];
idxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L150: */
}
/* Sort the singular values and corresponding singular vectors into */
/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */
/* which were not deflated go into the first K slots of DSIGMA, U2, */
/* and VT2 respectively, while those which were deflated go into the */
/* last N - K slots, except that the first column/row will be treated */
/* separately. */
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
dsigma[j] = d__[jp];
idxj = idxq[idx[idxp[idxc[j]]] + 1];
if (idxj <= nlp1) {
--idxj;
}
dcopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
dcopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
/* L160: */
}
/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */
dsigma[1] = 0.;
hlftol = tol / 2.;
if (abs(dsigma[2]) <= hlftol) {
dsigma[2] = hlftol;
}
if (m > n) {
z__[1] = dlapy2_(&z1, &z__[m]);
if (z__[1] <= tol) {
c__ = 1.;
s = 0.;
z__[1] = tol;
} else {
c__ = z1 / z__[1];
s = z__[m] / z__[1];
}
} else {
if (abs(z1) <= tol) {
z__[1] = tol;
} else {
z__[1] = z1;
}
}
/* Move the rest of the updating row to Z. */
i__1 = *k - 1;
dcopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
/* Determine the first column of U2, the first row of VT2 and the */
/* last row of VT. */
dlaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2);
u2[nlp1 + u2_dim1] = 1.;
if (m > n) {
i__1 = nlp1;
for (i__ = 1; i__ <= i__1; ++i__) {
vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
/* L170: */
}
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
/* L180: */
}
} else {
dcopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
}
if (m > n) {
dcopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
}
/* The deflated singular values and their corresponding vectors go */
/* into the back of D, U, and V respectively. */
if (n > *k) {
i__1 = n - *k;
dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = n - *k;
dlacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1)
* u_dim1 + 1], ldu);
i__1 = n - *k;
dlacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 +
vt_dim1], ldvt);
}
/* Copy CTOT into COLTYP for referencing in DLASD3. */
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
/* L190: */
}
return 0;
/* End of DLASD2 */
} /* dlasd2_ */

452
3rdparty/lapack/dlasd3.c vendored
View File

@ -1,452 +0,0 @@
/* dlasd3.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__0 = 0;
static doublereal c_b13 = 1.;
static doublereal c_b26 = 0.;
/* Subroutine */ int dlasd3_(integer *nl, integer *nr, integer *sqre, integer
*k, doublereal *d__, doublereal *q, integer *ldq, doublereal *dsigma,
doublereal *u, integer *ldu, doublereal *u2, integer *ldu2,
doublereal *vt, integer *ldvt, doublereal *vt2, integer *ldvt2,
integer *idxc, integer *ctot, doublereal *z__, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1,
vt_offset, vt2_dim1, vt2_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j, m, n, jc;
doublereal rho;
integer nlp1, nlp2, nrp1;
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 *);
integer ctemp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer ktemp;
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlacpy_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD3 finds all the square roots of the roots of the secular */
/* equation, as defined by the values in D and Z. It makes the */
/* appropriate calls to DLASD4 and then updates the singular */
/* vectors by matrix multiplication. */
/* 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. */
/* DLASD3 is called from DLASD1. */
/* Arguments */
/* ========= */
/* 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 N = NL + NR + 1 rows and */
/* M = N + SQRE >= N columns. */
/* K (input) INTEGER */
/* The size of the secular equation, 1 =< K = < N. */
/* D (output) DOUBLE PRECISION array, dimension(K) */
/* On exit the square roots of the roots of the secular equation, */
/* in ascending order. */
/* Q (workspace) DOUBLE PRECISION array, */
/* dimension at least (LDQ,K). */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= K. */
/* DSIGMA (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. */
/* U (output) DOUBLE PRECISION array, dimension (LDU, N) */
/* The last N - K columns of this matrix contain the deflated */
/* left singular vectors. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= N. */
/* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N) */
/* The first K columns of this matrix contain the non-deflated */
/* left singular vectors for the split problem. */
/* LDU2 (input) INTEGER */
/* The leading dimension of the array U2. LDU2 >= N. */
/* VT (output) DOUBLE PRECISION array, dimension (LDVT, M) */
/* The last M - K columns of VT' contain the deflated */
/* right singular vectors. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= N. */
/* VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N) */
/* The first K columns of VT2' contain the non-deflated */
/* right singular vectors for the split problem. */
/* LDVT2 (input) INTEGER */
/* The leading dimension of the array VT2. LDVT2 >= N. */
/* IDXC (input) INTEGER array, dimension ( N ) */
/* The permutation used to arrange the columns of U (and rows of */
/* VT) into three groups: the first group contains non-zero */
/* entries only at and above (or before) NL +1; the second */
/* contains non-zero entries only at and below (or after) NL+2; */
/* and the third is dense. The first column of U and the row of */
/* VT are treated separately, however. */
/* The rows of the singular vectors found by DLASD4 */
/* must be likewise permuted before the matrix multiplies can */
/* take place. */
/* CTOT (input) INTEGER array, dimension ( 4 ) */
/* A count of the total number of the various types of columns */
/* in U (or rows in VT), as described in IDXC. The fourth column */
/* type is any column which has been deflated. */
/* Z (input) DOUBLE PRECISION array, dimension (K) */
/* The first K elements of this array contain the components */
/* of the deflation-adjusted updating row vector. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, 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;
--dsigma;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxc;
--ctot;
--z__;
/* Function Body */
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre != 1 && *sqre != 0) {
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
nlp1 = *nl + 1;
nlp2 = *nl + 2;
if (*k < 1 || *k > n) {
*info = -4;
} else if (*ldq < *k) {
*info = -7;
} else if (*ldu < n) {
*info = -10;
} else if (*ldu2 < n) {
*info = -12;
} else if (*ldvt < m) {
*info = -14;
} else if (*ldvt2 < m) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD3", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 1) {
d__[1] = abs(z__[1]);
dcopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt);
if (z__[1] > 0.) {
dcopy_(&n, &u2[u2_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1);
} else {
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
u[i__ + u_dim1] = -u2[i__ + u2_dim1];
/* L10: */
}
}
return 0;
}
/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(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 DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DSIGMA(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*DSIGMA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
/* L20: */
}
/* Keep a copy of Z. */
dcopy_(k, &z__[1], &c__1, &q[q_offset], &c__1);
/* Normalize Z. */
rho = dnrm2_(k, &z__[1], &c__1);
dlascl_("G", &c__0, &c__0, &rho, &c_b13, k, &c__1, &z__[1], k, info);
rho *= rho;
/* Find the new singular values. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlasd4_(k, &j, &dsigma[1], &z__[1], &u[j * u_dim1 + 1], &rho, &d__[j],
&vt[j * vt_dim1 + 1], info);
/* If the zero finder fails, the computation is terminated. */
if (*info != 0) {
return 0;
}
/* L30: */
}
/* Compute updated Z. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
z__[i__] = u[i__ + *k * u_dim1] * vt[i__ + *k * vt_dim1];
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[
i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]);
/* L40: */
}
i__2 = *k - 1;
for (j = i__; j <= i__2; ++j) {
z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[
i__] - dsigma[j + 1]) / (dsigma[i__] + dsigma[j + 1]);
/* L50: */
}
d__2 = sqrt((d__1 = z__[i__], abs(d__1)));
z__[i__] = d_sign(&d__2, &q[i__ + q_dim1]);
/* L60: */
}
/* Compute left singular vectors of the modified diagonal matrix, */
/* and store related information for the right singular vectors. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
vt[i__ * vt_dim1 + 1] = z__[1] / u[i__ * u_dim1 + 1] / vt[i__ *
vt_dim1 + 1];
u[i__ * u_dim1 + 1] = -1.;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
vt[j + i__ * vt_dim1] = z__[j] / u[j + i__ * u_dim1] / vt[j + i__
* vt_dim1];
u[j + i__ * u_dim1] = dsigma[j] * vt[j + i__ * vt_dim1];
/* L70: */
}
temp = dnrm2_(k, &u[i__ * u_dim1 + 1], &c__1);
q[i__ * q_dim1 + 1] = u[i__ * u_dim1 + 1] / temp;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
jc = idxc[j];
q[j + i__ * q_dim1] = u[jc + i__ * u_dim1] / temp;
/* L80: */
}
/* L90: */
}
/* Update the left singular vector matrix. */
if (*k == 2) {
dgemm_("N", "N", &n, k, k, &c_b13, &u2[u2_offset], ldu2, &q[q_offset],
ldq, &c_b26, &u[u_offset], ldu);
goto L100;
}
if (ctot[1] > 0) {
dgemm_("N", "N", nl, k, &ctot[1], &c_b13, &u2[(u2_dim1 << 1) + 1],
ldu2, &q[q_dim1 + 2], ldq, &c_b26, &u[u_dim1 + 1], ldu);
if (ctot[3] > 0) {
ktemp = ctot[1] + 2 + ctot[2];
dgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1]
, ldu2, &q[ktemp + q_dim1], ldq, &c_b13, &u[u_dim1 + 1],
ldu);
}
} else if (ctot[3] > 0) {
ktemp = ctot[1] + 2 + ctot[2];
dgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1],
ldu2, &q[ktemp + q_dim1], ldq, &c_b26, &u[u_dim1 + 1], ldu);
} else {
dlacpy_("F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu);
}
dcopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu);
ktemp = ctot[1] + 2;
ctemp = ctot[2] + ctot[3];
dgemm_("N", "N", nr, k, &ctemp, &c_b13, &u2[nlp2 + ktemp * u2_dim1], ldu2,
&q[ktemp + q_dim1], ldq, &c_b26, &u[nlp2 + u_dim1], ldu);
/* Generate the right singular vectors. */
L100:
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = dnrm2_(k, &vt[i__ * vt_dim1 + 1], &c__1);
q[i__ + q_dim1] = vt[i__ * vt_dim1 + 1] / temp;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
jc = idxc[j];
q[i__ + j * q_dim1] = vt[jc + i__ * vt_dim1] / temp;
/* L110: */
}
/* L120: */
}
/* Update the right singular vector matrix. */
if (*k == 2) {
dgemm_("N", "N", k, &m, k, &c_b13, &q[q_offset], ldq, &vt2[vt2_offset]
, ldvt2, &c_b26, &vt[vt_offset], ldvt);
return 0;
}
ktemp = ctot[1] + 1;
dgemm_("N", "N", k, &nlp1, &ktemp, &c_b13, &q[q_dim1 + 1], ldq, &vt2[
vt2_dim1 + 1], ldvt2, &c_b26, &vt[vt_dim1 + 1], ldvt);
ktemp = ctot[1] + 2 + ctot[2];
if (ktemp <= *ldvt2) {
dgemm_("N", "N", k, &nlp1, &ctot[3], &c_b13, &q[ktemp * q_dim1 + 1],
ldq, &vt2[ktemp + vt2_dim1], ldvt2, &c_b13, &vt[vt_dim1 + 1],
ldvt);
}
ktemp = ctot[1] + 1;
nrp1 = *nr + *sqre;
if (ktemp > 1) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
q[i__ + ktemp * q_dim1] = q[i__ + q_dim1];
/* L130: */
}
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
vt2[ktemp + i__ * vt2_dim1] = vt2[i__ * vt2_dim1 + 1];
/* L140: */
}
}
ctemp = ctot[2] + 1 + ctot[3];
dgemm_("N", "N", k, &nrp1, &ctemp, &c_b13, &q[ktemp * q_dim1 + 1], ldq, &
vt2[ktemp + nlp2 * vt2_dim1], ldvt2, &c_b26, &vt[nlp2 * vt_dim1 +
1], ldvt);
return 0;
/* End of DLASD3 */
} /* dlasd3_ */

1010
3rdparty/lapack/dlasd4.c vendored
View File

File diff suppressed because it is too large Load Diff

189
3rdparty/lapack/dlasd5.c vendored
View File

@ -1,189 +0,0 @@
/* dlasd5.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 dlasd5_(integer *i__, doublereal *d__, doublereal *z__,
doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal *
work)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal b, c__, w, del, tau, delsq;
/* -- LAPACK auxiliary 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 square root of the I-th eigenvalue */
/* of a positive symmetric rank-one modification of a 2-by-2 diagonal */
/* matrix */
/* diag( D ) * diag( D ) + RHO * Z * transpose(Z) . */
/* The diagonal entries in the array D are assumed to satisfy */
/* 0 <= 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 0 <= D(1) < D(2). */
/* Z (input) DOUBLE PRECISION array, dimension ( 2 ) */
/* The components of the updating vector. */
/* DELTA (output) DOUBLE PRECISION array, dimension ( 2 ) */
/* Contains (D(j) - sigma_I) in its j-th component. */
/* The vector DELTA contains the information necessary */
/* to construct the eigenvectors. */
/* RHO (input) DOUBLE PRECISION */
/* The scalar in the symmetric updating formula. */
/* DSIGMA (output) DOUBLE PRECISION */
/* The computed sigma_I, the I-th updated eigenvalue. */
/* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 ) */
/* WORK contains (D(j) + sigma_I) in its j-th component. */
/* 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 */
--work;
--delta;
--z__;
--d__;
/* Function Body */
del = d__[2] - d__[1];
delsq = del * (d__[2] + d__[1]);
if (*i__ == 1) {
w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] *
z__[1] / (d__[1] * 3. + d__[2])) / del + 1.;
if (w > 0.) {
b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[1] * z__[1] * delsq;
/* B > ZERO, always */
/* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */
tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1))));
/* The following TAU is DSIGMA - D( 1 ) */
tau /= d__[1] + sqrt(d__[1] * d__[1] + tau);
*dsigma = d__[1] + tau;
delta[1] = -tau;
delta[2] = del - tau;
work[1] = d__[1] * 2. + tau;
work[2] = d__[1] + tau + d__[2];
/* DELTA( 1 ) = -Z( 1 ) / TAU */
/* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */
} else {
b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * delsq;
/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
if (b > 0.) {
tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.));
} else {
tau = (b - sqrt(b * b + c__ * 4.)) / 2.;
}
/* The following TAU is DSIGMA - D( 2 ) */
tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1)));
*dsigma = d__[2] + tau;
delta[1] = -(del + tau);
delta[2] = -tau;
work[1] = d__[1] + tau + d__[2];
work[2] = d__[2] * 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 ) = DELTA( 1 ) / TEMP */
/* DELTA( 2 ) = DELTA( 2 ) / TEMP */
} else {
/* Now I=2 */
b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
c__ = *rho * z__[2] * z__[2] * delsq;
/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
if (b > 0.) {
tau = (b + sqrt(b * b + c__ * 4.)) / 2.;
} else {
tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.));
}
/* The following TAU is DSIGMA - D( 2 ) */
tau /= d__[2] + sqrt(d__[2] * d__[2] + tau);
*dsigma = d__[2] + tau;
delta[1] = -(del + tau);
delta[2] = -tau;
work[1] = d__[1] + tau + d__[2];
work[2] = d__[2] * 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 ) = DELTA( 1 ) / TEMP */
/* DELTA( 2 ) = DELTA( 2 ) / TEMP */
}
return 0;
/* End of DLASD5 */
} /* dlasd5_ */

367
3rdparty/lapack/dlasd6.c vendored
View File

@ -1,367 +0,0 @@
/* dlasd6.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__0 = 0;
static doublereal c_b7 = 1.;
static integer c__1 = 1;
static integer c_n1 = -1;
/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr,
integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl,
doublereal *alpha, doublereal *beta, integer *idxq, 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 *iwork, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dlasd7_(integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *), dlasd8_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlamrg_(integer *, integer *,
doublereal *, integer *, integer *, integer *);
integer isigma;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal orgnrm;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD6 computes the SVD of an updated upper bidiagonal matrix B */
/* obtained by merging two smaller ones by appending a row. This */
/* routine is used only for the problem which requires all singular */
/* values and optionally singular vector matrices in factored form. */
/* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. */
/* A related subroutine, DLASD1, handles the case in which all singular */
/* values and singular vectors of the bidiagonal matrix are desired. */
/* DLASD6 computes the SVD as follows: */
/* ( D1(in) 0 0 0 ) */
/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */
/* ( 0 0 D2(in) 0 ) */
/* = U(out) * ( D(out) 0) * VT(out) */
/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */
/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */
/* elsewhere; and the entry b is empty if SQRE = 0. */
/* The singular values of B can be computed using D1, D2, the first */
/* components of all the right singular vectors of the lower block, and */
/* the last components of all the right singular vectors of the upper */
/* block. These components are stored and updated in VF and VL, */
/* respectively, in DLASD6. Hence U and VT are not explicitly */
/* referenced. */
/* The singular values are stored in D. The algorithm consists of two */
/* stages: */
/* The first stage consists of deflating the size of the problem */
/* when there are multiple singular values 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 DLASD7. */
/* The second stage consists of calculating the updated */
/* singular values. This is done by finding the roots of the */
/* secular equation via the routine DLASD4 (as called by DLASD8). */
/* This routine also updates VF and VL and computes the distances */
/* between the updated singular values and the old singular */
/* values. */
/* DLASD6 is called from DLASDA. */
/* Arguments */
/* ========= */
/* ICOMPQ (input) INTEGER */
/* Specifies whether singular vectors are to be computed in */
/* factored form: */
/* = 0: Compute singular values only. */
/* = 1: Compute singular vectors in factored form as well. */
/* 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. */
/* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ). */
/* On entry D(1:NL,1:NL) contains the singular values of the */
/* upper block, and D(NL+2:N) contains the singular values */
/* of the lower block. On exit D(1:N) contains the singular */
/* values of the modified matrix. */
/* VF (input/output) DOUBLE PRECISION array, dimension ( M ) */
/* On entry, VF(1:NL+1) contains the first components of all */
/* right singular vectors of the upper block; and VF(NL+2:M) */
/* contains the first components of all right singular vectors */
/* of the lower block. On exit, VF contains the first components */
/* of all right singular vectors of the bidiagonal matrix. */
/* VL (input/output) DOUBLE PRECISION array, dimension ( M ) */
/* On entry, VL(1:NL+1) contains the last components of all */
/* right singular vectors of the upper block; and VL(NL+2:M) */
/* contains the last components of all right singular vectors of */
/* the lower block. On exit, VL contains the last components of */
/* all right singular vectors of the bidiagonal matrix. */
/* ALPHA (input/output) DOUBLE PRECISION */
/* Contains the diagonal element associated with the added row. */
/* BETA (input/output) DOUBLE PRECISION */
/* Contains the off-diagonal element associated with the added */
/* row. */
/* IDXQ (output) INTEGER array, dimension ( N ) */
/* This contains the permutation which will reintegrate the */
/* subproblem just solved back into sorted order, i.e. */
/* D( IDXQ( I = 1, N ) ) will be in ascending order. */
/* PERM (output) INTEGER array, dimension ( N ) */
/* The permutations (from deflation and sorting) to be applied */
/* to each block. Not referenced if ICOMPQ = 0. */
/* GIVPTR (output) INTEGER */
/* The number of Givens rotations which took place in this */
/* subproblem. Not referenced if ICOMPQ = 0. */
/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */
/* Each pair of numbers indicates a pair of columns to take place */
/* in a Givens rotation. Not referenced if ICOMPQ = 0. */
/* LDGCOL (input) INTEGER */
/* leading dimension of GIVCOL, must be at least N. */
/* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
/* Each number indicates the C or S value to be used in the */
/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */
/* LDGNUM (input) INTEGER */
/* The leading dimension of GIVNUM and POLES, must be at least N. */
/* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
/* On exit, POLES(1,*) is an array containing the new singular */
/* values obtained from solving the secular equation, and */
/* POLES(2,*) is an array containing the poles in the secular */
/* equation. Not referenced if ICOMPQ = 0. */
/* DIFL (output) DOUBLE PRECISION array, dimension ( N ) */
/* On exit, DIFL(I) is the distance between I-th updated */
/* (undeflated) singular value and the I-th (undeflated) old */
/* singular value. */
/* DIFR (output) DOUBLE PRECISION array, */
/* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and */
/* dimension ( N ) if ICOMPQ = 0. */
/* On exit, DIFR(I, 1) is the distance between I-th updated */
/* (undeflated) singular value and the I+1-th (undeflated) old */
/* singular value. */
/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
/* normalizing factors for the right singular vector matrix. */
/* See DLASD8 for details on DIFL and DIFR. */
/* Z (output) DOUBLE PRECISION array, dimension ( M ) */
/* The first elements of this array contain the components */
/* of the deflation-adjusted updating row vector. */
/* K (output) INTEGER */
/* Contains the dimension of the non-deflated matrix, */
/* This is the order of the related secular equation. 1 <= K <=N. */
/* C (output) 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 (output) 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 ( 4 * M ) */
/* 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: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, 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__;
--vf;
--vl;
--idxq;
--perm;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1;
givcol -= givcol_offset;
poles_dim1 = *ldgnum;
poles_offset = 1 + poles_dim1;
poles -= poles_offset;
givnum_dim1 = *ldgnum;
givnum_offset = 1 + givnum_dim1;
givnum -= givnum_offset;
--difl;
--difr;
--z__;
--work;
--iwork;
/* Function Body */
*info = 0;
n = *nl + *nr + 1;
m = n + *sqre;
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;
} else if (*ldgcol < n) {
*info = -14;
} else if (*ldgnum < n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD6", &i__1);
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 DLASD7 and DLASD8. */
isigma = 1;
iw = isigma + n;
ivfw = iw + m;
ivlw = ivfw + m;
idx = 1;
idxc = idx + n;
idxp = idxc + n;
/* Scale. */
/* Computing MAX */
d__1 = abs(*alpha), d__2 = abs(*beta);
orgnrm = max(d__1,d__2);
d__[*nl + 1] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) > orgnrm) {
orgnrm = (d__1 = d__[i__], abs(d__1));
}
/* L10: */
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info);
*alpha /= orgnrm;
*beta /= orgnrm;
/* Sort and Deflate singular values. */
dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], &
work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], &
iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[
givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s,
info);
/* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */
dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1],
ldgnum, &work[isigma], &work[iw], info);
/* Save the poles if ICOMPQ = 1. */
if (*icompq == 1) {
dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1);
dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1);
}
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info);
/* Prepare the IDXQ sorting permutation. */
n1 = *k;
n2 = n - *k;
dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
return 0;
/* End of DLASD6 */
} /* dlasd6_ */

518
3rdparty/lapack/dlasd7.c vendored
View File

@ -1,518 +0,0 @@
/* dlasd7.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 dlasd7_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *k, doublereal *d__, doublereal *z__,
doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl,
doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *
dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm,
integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
integer *ldgnum, doublereal *c__, doublereal *s, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer i__, j, m, n, k2;
doublereal z1;
integer jp;
doublereal eps, tau, tol;
integer nlp1, nlp2, idxi, idxj;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer idxjp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer jprev;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *);
doublereal hlftol;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD7 merges the two sets of singular values 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 singular */
/* values 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. */
/* DLASD7 is called from DLASD6. */
/* Arguments */
/* ========= */
/* ICOMPQ (input) INTEGER */
/* Specifies whether singular vectors are to be computed */
/* in compact form, as follows: */
/* = 0: Compute singular values only. */
/* = 1: Compute singular vectors of upper */
/* bidiagonal matrix in compact form. */
/* 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 */
/* N = NL + NR + 1 rows and */
/* M = N + SQRE >= N columns. */
/* K (output) INTEGER */
/* Contains the dimension of the non-deflated matrix, this is */
/* the order of the related secular equation. 1 <= K <=N. */
/* D (input/output) DOUBLE PRECISION array, dimension ( N ) */
/* On entry D contains the singular values of the two submatrices */
/* to be combined. On exit D contains the trailing (N-K) updated */
/* singular values (those which were deflated) sorted into */
/* increasing order. */
/* Z (output) DOUBLE PRECISION array, dimension ( M ) */
/* On exit Z contains the updating row vector in the secular */
/* equation. */
/* ZW (workspace) DOUBLE PRECISION array, dimension ( M ) */
/* Workspace for Z. */
/* VF (input/output) DOUBLE PRECISION array, dimension ( M ) */
/* On entry, VF(1:NL+1) contains the first components of all */
/* right singular vectors of the upper block; and VF(NL+2:M) */
/* contains the first components of all right singular vectors */
/* of the lower block. On exit, VF contains the first components */
/* of all right singular vectors of the bidiagonal matrix. */
/* VFW (workspace) DOUBLE PRECISION array, dimension ( M ) */
/* Workspace for VF. */
/* VL (input/output) DOUBLE PRECISION array, dimension ( M ) */
/* On entry, VL(1:NL+1) contains the last components of all */
/* right singular vectors of the upper block; and VL(NL+2:M) */
/* contains the last components of all right singular vectors */
/* of the lower block. On exit, VL contains the last components */
/* of all right singular vectors of the bidiagonal matrix. */
/* VLW (workspace) DOUBLE PRECISION array, dimension ( M ) */
/* Workspace for VL. */
/* ALPHA (input) DOUBLE PRECISION */
/* Contains the diagonal element associated with the added row. */
/* BETA (input) DOUBLE PRECISION */
/* Contains the off-diagonal element associated with the added */
/* row. */
/* DSIGMA (output) DOUBLE PRECISION array, dimension ( N ) */
/* Contains a copy of the diagonal elements (K-1 singular values */
/* and one zero) in the secular equation. */
/* IDX (workspace) INTEGER array, dimension ( N ) */
/* This will contain the permutation used to sort the contents of */
/* D into ascending order. */
/* IDXP (workspace) INTEGER array, dimension ( N ) */
/* This will contain the permutation used to place deflated */
/* values of D at the end of the array. On output IDXP(2:K) */
/* points to the nondeflated D-values and IDXP(K+1:N) */
/* points to the deflated singular values. */
/* IDXQ (input) INTEGER array, dimension ( N ) */
/* This contains the permutation which separately sorts the two */
/* sub-problems in D into ascending order. Note that entries in */
/* the first half of this permutation must first be moved one */
/* position backward; and entries in the second half */
/* must first have NL+1 added to their values. */
/* PERM (output) INTEGER array, dimension ( N ) */
/* The permutations (from deflation and sorting) to be applied */
/* to each singular block. Not referenced if ICOMPQ = 0. */
/* GIVPTR (output) INTEGER */
/* The number of Givens rotations which took place in this */
/* subproblem. Not referenced if ICOMPQ = 0. */
/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */
/* Each pair of numbers indicates a pair of columns to take place */
/* in a Givens rotation. Not referenced if ICOMPQ = 0. */
/* LDGCOL (input) INTEGER */
/* The leading dimension of GIVCOL, must be at least N. */
/* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
/* Each number indicates the C or S value to be used in the */
/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */
/* LDGNUM (input) INTEGER */
/* The leading dimension of GIVNUM, must be at least N. */
/* C (output) 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 (output) 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. */
/* 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 Huan Ren, 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__;
--z__;
--zw;
--vf;
--vfw;
--vl;
--vlw;
--dsigma;
--idx;
--idxp;
--idxq;
--perm;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1;
givcol -= givcol_offset;
givnum_dim1 = *ldgnum;
givnum_offset = 1 + givnum_dim1;
givnum -= givnum_offset;
/* Function Body */
*info = 0;
n = *nl + *nr + 1;
m = n + *sqre;
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;
} else if (*ldgcol < n) {
*info = -22;
} else if (*ldgnum < n) {
*info = -24;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD7", &i__1);
return 0;
}
nlp1 = *nl + 1;
nlp2 = *nl + 2;
if (*icompq == 1) {
*givptr = 0;
}
/* Generate the first part of the vector Z and move the singular */
/* values in the first part of D one position backward. */
z1 = *alpha * vl[nlp1];
vl[nlp1] = 0.;
tau = vf[nlp1];
for (i__ = *nl; i__ >= 1; --i__) {
z__[i__ + 1] = *alpha * vl[i__];
vl[i__] = 0.;
vf[i__ + 1] = vf[i__];
d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1;
/* L10: */
}
vf[1] = tau;
/* Generate the second part of the vector Z. */
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
z__[i__] = *beta * vf[i__];
vf[i__] = 0.;
/* L20: */
}
/* Sort the singular values into increasing order */
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
idxq[i__] += nlp1;
/* L30: */
}
/* DSIGMA, IDXC, IDXC, and ZW are used as storage space. */
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
dsigma[i__] = d__[idxq[i__]];
zw[i__] = z__[idxq[i__]];
vfw[i__] = vf[idxq[i__]];
vlw[i__] = vl[idxq[i__]];
/* L40: */
}
dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
idxi = idx[i__] + 1;
d__[i__] = dsigma[idxi];
z__[i__] = zw[idxi];
vf[i__] = vfw[idxi];
vl[i__] = vlw[idxi];
/* L50: */
}
/* Calculate the allowable deflation tolerence */
eps = dlamch_("Epsilon");
/* Computing MAX */
d__1 = abs(*alpha), d__2 = abs(*beta);
tol = max(d__1,d__2);
/* Computing MAX */
d__2 = (d__1 = d__[n], abs(d__1));
tol = eps * 64. * max(d__2,tol);
/* There are 2 kinds of deflation -- first a value in the z-vector */
/* is small, second two (or more) singular values are very close */
/* together (their difference is small). */
/* If the value in the z-vector is small, we simply permute the */
/* array so that the corresponding singular value is moved to the */
/* end. */
/* If two values in the D-vector are close, we perform a two-sided */
/* rotation designed to make one of the corresponding z-vector */
/* entries zero, and then permute the array so that the deflated */
/* singular value is moved to the end. */
/* If there are multiple singular values then the problem deflates. */
/* Here the number of equal singular values are found. As each equal */
/* singular value is found, an elementary reflector is computed to */
/* rotate the corresponding singular subspace so that the */
/* corresponding components of Z are zero in this new basis. */
*k = 1;
k2 = n + 1;
i__1 = n;
for (j = 2; j <= i__1; ++j) {
if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
if (j == n) {
goto L100;
}
} else {
jprev = j;
goto L70;
}
/* L60: */
}
L70:
j = jprev;
L80:
++j;
if (j > n) {
goto L90;
}
if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
} else {
/* Check if singular values are close enough to allow deflation. */
if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
/* Deflation is possible. */
*s = z__[jprev];
*c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = dlapy2_(c__, s);
z__[j] = tau;
z__[jprev] = 0.;
*c__ /= tau;
*s = -(*s) / tau;
/* Record the appropriate Givens rotation */
if (*icompq == 1) {
++(*givptr);
idxjp = idxq[idx[jprev] + 1];
idxj = idxq[idx[j] + 1];
if (idxjp <= nlp1) {
--idxjp;
}
if (idxj <= nlp1) {
--idxj;
}
givcol[*givptr + (givcol_dim1 << 1)] = idxjp;
givcol[*givptr + givcol_dim1] = idxj;
givnum[*givptr + (givnum_dim1 << 1)] = *c__;
givnum[*givptr + givnum_dim1] = *s;
}
drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s);
drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s);
--k2;
idxp[k2] = jprev;
jprev = j;
} else {
++(*k);
zw[*k] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
jprev = j;
}
}
goto L80;
L90:
/* Record the last singular value. */
++(*k);
zw[*k] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
L100:
/* Sort the singular values into DSIGMA. The singular values which */
/* were not deflated go into the first K slots of DSIGMA, except */
/* that DSIGMA(1) is treated separately. */
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
dsigma[j] = d__[jp];
vfw[j] = vf[jp];
vlw[j] = vl[jp];
/* L110: */
}
if (*icompq == 1) {
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
perm[j] = idxq[idx[jp] + 1];
if (perm[j] <= nlp1) {
--perm[j];
}
/* L120: */
}
}
/* The deflated singular values go back into the last N - K slots of */
/* D. */
i__1 = n - *k;
dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
/* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and */
/* VL(M). */
dsigma[1] = 0.;
hlftol = tol / 2.;
if (abs(dsigma[2]) <= hlftol) {
dsigma[2] = hlftol;
}
if (m > n) {
z__[1] = dlapy2_(&z1, &z__[m]);
if (z__[1] <= tol) {
*c__ = 1.;
*s = 0.;
z__[1] = tol;
} else {
*c__ = z1 / z__[1];
*s = -z__[m] / z__[1];
}
drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s);
drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s);
} else {
if (abs(z1) <= tol) {
z__[1] = tol;
} else {
z__[1] = z1;
}
}
/* Restore Z, VF, and VL. */
i__1 = *k - 1;
dcopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1);
i__1 = n - 1;
dcopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1);
i__1 = n - 1;
dcopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1);
return 0;
/* End of DLASD7 */
} /* dlasd7_ */

326
3rdparty/lapack/dlasd8.c vendored
View File

@ -1,326 +0,0 @@
/* dlasd8.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__0 = 0;
static doublereal c_b8 = 1.;
/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__,
doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl,
doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *
work, integer *info)
{
/* System generated locals */
integer difr_dim1, difr_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j;
doublereal dj, rho;
integer iwk1, iwk2, iwk3;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
integer iwk2i, iwk3i;
doublereal diflj, difrj, dsigj;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
doublereal dsigjp;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* October 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD8 finds the square roots of the roots of the secular equation, */
/* as defined by the values in DSIGMA and Z. It makes the appropriate */
/* calls to DLASD4, and stores, for each element in D, the distance */
/* to its two nearest poles (elements in DSIGMA). It also updates */
/* the arrays VF and VL, the first and last components of all the */
/* right singular vectors of the original bidiagonal matrix. */
/* DLASD8 is called from DLASD6. */
/* Arguments */
/* ========= */
/* ICOMPQ (input) INTEGER */
/* Specifies whether singular vectors are to be computed in */
/* factored form in the calling routine: */
/* = 0: Compute singular values only. */
/* = 1: Compute singular vectors in factored form as well. */
/* K (input) INTEGER */
/* The number of terms in the rational function to be solved */
/* by DLASD4. K >= 1. */
/* D (output) DOUBLE PRECISION array, dimension ( K ) */
/* On output, D contains the updated singular values. */
/* Z (input/output) DOUBLE PRECISION array, dimension ( K ) */
/* On entry, the first K elements of this array contain the */
/* components of the deflation-adjusted updating row vector. */
/* On exit, Z is updated. */
/* VF (input/output) DOUBLE PRECISION array, dimension ( K ) */
/* On entry, VF contains information passed through DBEDE8. */
/* On exit, VF contains the first K components of the first */
/* components of all right singular vectors of the bidiagonal */
/* matrix. */
/* VL (input/output) DOUBLE PRECISION array, dimension ( K ) */
/* On entry, VL contains information passed through DBEDE8. */
/* On exit, VL contains the first K components of the last */
/* components of all right singular vectors of the bidiagonal */
/* matrix. */
/* DIFL (output) DOUBLE PRECISION array, dimension ( K ) */
/* On exit, DIFL(I) = D(I) - DSIGMA(I). */
/* DIFR (output) DOUBLE PRECISION array, */
/* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */
/* dimension ( K ) if ICOMPQ = 0. */
/* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */
/* defined and will not be referenced. */
/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
/* normalizing factors for the right singular vector matrix. */
/* LDDIFR (input) INTEGER */
/* The leading dimension of DIFR, must be at least K. */
/* DSIGMA (input/output) DOUBLE PRECISION array, dimension ( K ) */
/* On entry, the first K elements of this array contain the old */
/* roots of the deflated updating problem. These are the poles */
/* of the secular equation. */
/* On exit, the elements of DSIGMA may be very slightly altered */
/* in value. */
/* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, 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__;
--z__;
--vf;
--vl;
--difl;
difr_dim1 = *lddifr;
difr_offset = 1 + difr_dim1;
difr -= difr_offset;
--dsigma;
--work;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*k < 1) {
*info = -2;
} else if (*lddifr < *k) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD8", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 1) {
d__[1] = abs(z__[1]);
difl[1] = d__[1];
if (*icompq == 1) {
difl[2] = 1.;
difr[(difr_dim1 << 1) + 1] = 1.;
}
return 0;
}
/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(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 DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DSIGMA(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__) {
dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
/* L10: */
}
/* Book keeping. */
iwk1 = 1;
iwk2 = iwk1 + *k;
iwk3 = iwk2 + *k;
iwk2i = iwk2 - 1;
iwk3i = iwk3 - 1;
/* Normalize Z. */
rho = dnrm2_(k, &z__[1], &c__1);
dlascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info);
rho *= rho;
/* Initialize WORK(IWK3). */
dlaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k);
/* Compute the updated singular values, the arrays DIFL, DIFR, */
/* and the updated Z. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
iwk2], info);
/* If the root finder fails, the computation is terminated. */
if (*info != 0) {
return 0;
}
work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j];
difl[j] = -work[j];
difr[j + difr_dim1] = -work[j + 1];
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L20: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L30: */
}
/* L40: */
}
/* Compute updated Z. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1)));
z__[i__] = d_sign(&d__2, &z__[i__]);
/* L50: */
}
/* Update VF and VL. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
dj = d__[j];
dsigj = -dsigma[j];
if (j < *k) {
difrj = -difr[j + difr_dim1];
dsigjp = -dsigma[j + 1];
}
work[j] = -z__[j] / diflj / (dsigma[j] + dj);
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (
dsigma[i__] + dj);
/* L60: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) /
(dsigma[i__] + dj);
/* L70: */
}
temp = dnrm2_(k, &work[1], &c__1);
work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp;
if (*icompq == 1) {
difr[j + (difr_dim1 << 1)] = temp;
}
/* L80: */
}
dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1);
dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1);
return 0;
/* End of DLASD8 */
} /* dlasd8_ */

488
3rdparty/lapack/dlasda.c vendored
View File

@ -1,488 +0,0 @@
/* dlasda.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__0 = 0;
static doublereal c_b11 = 0.;
static doublereal c_b12 = 1.;
static integer c__1 = 1;
static integer c__2 = 2;
/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n,
integer *sqre, doublereal *d__, doublereal *e, 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, 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, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf,
vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1;
doublereal beta;
integer idxq, nlvl;
doublereal alpha;
integer inode, ndiml, ndimr, idxqi, itemp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer sqrei;
extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
integer nwork1, nwork2;
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *), dlasdt_(integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlaset_(
char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *);
integer smlszp;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Using a divide and conquer approach, DLASDA computes the singular */
/* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix */
/* B with diagonal D and offdiagonal E, where M = N + SQRE. The */
/* algorithm computes the singular values in the SVD B = U * S * VT. */
/* The orthogonal matrices U and VT are optionally computed in */
/* compact form. */
/* A related subroutine, DLASD0, computes the singular values and */
/* the singular vectors in explicit form. */
/* Arguments */
/* ========= */
/* ICOMPQ (input) INTEGER */
/* Specifies whether singular vectors are to be computed */
/* in compact form, as follows */
/* = 0: Compute singular values only. */
/* = 1: Compute singular vectors of upper bidiagonal */
/* matrix in compact form. */
/* SMLSIZ (input) INTEGER */
/* The maximum size of the subproblems at the bottom of the */
/* computation tree. */
/* N (input) INTEGER */
/* The row dimension of the upper bidiagonal matrix. This is */
/* also the dimension of the main diagonal array D. */
/* SQRE (input) INTEGER */
/* Specifies the column dimension of the bidiagonal matrix. */
/* = 0: The bidiagonal matrix has column dimension M = N; */
/* = 1: The bidiagonal matrix has column dimension M = N + 1. */
/* D (input/output) DOUBLE PRECISION array, dimension ( N ) */
/* On entry D contains the main diagonal of the bidiagonal */
/* matrix. On exit D, if INFO = 0, contains its singular values. */
/* E (input) DOUBLE PRECISION array, dimension ( M-1 ) */
/* Contains the subdiagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* U (output) DOUBLE PRECISION array, */
/* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced */
/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, 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 (output) DOUBLE PRECISION array, */
/* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced */
/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right */
/* singular vector matrices of all subproblems at the bottom */
/* level. */
/* K (output) INTEGER array, */
/* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. */
/* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th */
/* secular equation on the computation tree. */
/* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ), */
/* where NLVL = floor(log_2 (N/SMLSIZ))). */
/* DIFR (output) DOUBLE PRECISION array, */
/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and */
/* dimension ( N ) if ICOMPQ = 0. */
/* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) */
/* record distances between singular values on the I-th */
/* level and singular values on the (I -1)-th level, and */
/* DIFR(1:N, 2 * I ) contains the normalizing factors for */
/* the right singular vector matrix. See DLASD8 for details. */
/* Z (output) DOUBLE PRECISION array, */
/* dimension ( LDU, NLVL ) if ICOMPQ = 1 and */
/* dimension ( N ) if ICOMPQ = 0. */
/* The first K elements of Z(1, I) contain the components of */
/* the deflation-adjusted updating row vector for subproblems */
/* on the I-th level. */
/* POLES (output) DOUBLE PRECISION array, */
/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced */
/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and */
/* POLES(1, 2*I) contain the new and old singular values */
/* involved in the secular equations on the I-th level. */
/* GIVPTR (output) INTEGER array, */
/* dimension ( N ) if ICOMPQ = 1, and not referenced if */
/* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records */
/* the number of Givens rotations performed on the I-th */
/* problem on the computation tree. */
/* GIVCOL (output) INTEGER array, */
/* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not */
/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
/* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record 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 (output) INTEGER array, */
/* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced */
/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records */
/* permutations done on the I-th level of the computation tree. */
/* GIVNUM (output) DOUBLE PRECISION array, */
/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not */
/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
/* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- */
/* values of Givens rotations performed on the I-th level on */
/* the computation tree. */
/* C (output) DOUBLE PRECISION array, */
/* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. */
/* If ICOMPQ = 1 and the I-th subproblem is not square, on exit, */
/* C( I ) contains the C-value of a Givens rotation related to */
/* the right null space of the I-th subproblem. */
/* S (output) DOUBLE PRECISION array, dimension ( N ) if */
/* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 */
/* and the I-th subproblem is not square, on exit, 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, dimension */
/* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */
/* IWORK (workspace) INTEGER array. */
/* Dimension must be at least (7 * N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
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 < 0) {
*info = -3;
} else if (*sqre < 0 || *sqre > 1) {
*info = -4;
} else if (*ldu < *n + *sqre) {
*info = -8;
} else if (*ldgcol < *n) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASDA", &i__1);
return 0;
}
m = *n + *sqre;
/* If the input matrix is too small, call DLASDQ to find the SVD. */
if (*n <= *smlsiz) {
if (*icompq == 0) {
dlasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, &
work[1], info);
} else {
dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1],
info);
}
return 0;
}
/* Book-keeping and set up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
idxq = ndimr + *n;
iwk = idxq + *n;
ncc = 0;
nru = 0;
smlszp = *smlsiz + 1;
vf = 1;
vl = vf + m;
nwork1 = vl + m;
nwork2 = nwork1 + smlszp * smlszp;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* for the nodes on bottom level of the tree, solve */
/* their subproblems by DLASDQ. */
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];
nlp1 = nl + 1;
nr = iwork[ndimr + i1];
nlf = ic - nl;
nrf = ic + 1;
idxqi = idxq + nlf - 2;
vfi = vf + nlf - 1;
vli = vl + nlf - 1;
sqrei = 1;
if (*icompq == 0) {
dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
dlasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &
work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2],
&nl, &work[nwork2], info);
itemp = nwork1 + nl * smlszp;
dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
dlaset_("A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu);
dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1],
ldu);
dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &
vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf +
u_dim1], ldu, &work[nwork1], info);
dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1)
;
}
if (*info != 0) {
return 0;
}
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L10: */
}
if (i__ == nd && *sqre == 0) {
sqrei = 0;
} else {
sqrei = 1;
}
idxqi += nlp1;
vfi += nlp1;
vli += nlp1;
nrp1 = nr + sqrei;
if (*icompq == 0) {
dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
dlasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &
work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2],
&nr, &work[nwork2], info);
itemp = nwork1 + (nrp1 - 1) * smlszp;
dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
dlaset_("A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu);
dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1],
ldu);
dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &
vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf +
u_dim1], ldu, &work[nwork1], info);
dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1)
;
}
if (*info != 0) {
return 0;
}
i__2 = nr;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L20: */
}
/* L30: */
}
/* Now conquer each subproblem bottom-up. */
j = pow_ii(&c__2, &nlvl);
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;
if (i__ == ll) {
sqrei = *sqre;
} else {
sqrei = 1;
}
vfi = vf + nlf - 1;
vli = vl + nlf - 1;
idxqi = idxq + nlf - 1;
alpha = d__[ic];
beta = e[ic];
if (*icompq == 0) {
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[
perm_offset], &givptr[1], &givcol[givcol_offset],
ldgcol, &givnum[givnum_offset], ldu, &poles[
poles_offset], &difl[difl_offset], &difr[difr_offset],
&z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1],
&iwork[iwk], info);
} else {
--j;
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &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[nwork1], &iwork[iwk], info);
}
if (*info != 0) {
return 0;
}
/* L40: */
}
/* L50: */
}
return 0;
/* End of DLASDA */
} /* dlasda_ */

380
3rdparty/lapack/dlasdq.c vendored
View File

@ -1,380 +0,0 @@
/* dlasdq.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 dlasdq_(char *uplo, integer *sqre, 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;
/* Local variables */
integer i__, j;
doublereal r__, cs, sn;
integer np1, isub;
doublereal smin;
integer sqre1;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *), dswap_(integer *, doublereal *, integer *
, doublereal *, integer *);
integer iuplo;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *), dbdsqr_(char *, integer *, integer *, integer
*, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
logical rotate;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASDQ computes the singular value decomposition (SVD) of a real */
/* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal */
/* E, accumulating the transformations if desired. Letting B denote */
/* the input bidiagonal matrix, the algorithm computes orthogonal */
/* matrices Q and P such that B = Q * S * P' (P' denotes the transpose */
/* of P). The singular values S are overwritten on D. */
/* The input matrix U is changed to U * Q if desired. */
/* The input matrix VT is changed to P' * VT if desired. */
/* The input matrix C is changed to Q' * C if desired. */
/* See "Computing Small Singular Values of Bidiagonal Matrices With */
/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
/* LAPACK Working Note #3, for a detailed description of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* On entry, UPLO specifies whether the input bidiagonal matrix */
/* is upper or lower bidiagonal, and wether it is square are */
/* not. */
/* UPLO = 'U' or 'u' B is upper bidiagonal. */
/* UPLO = 'L' or 'l' B is lower bidiagonal. */
/* SQRE (input) INTEGER */
/* = 0: then the input matrix is N-by-N. */
/* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and */
/* (N+1)-by-N if UPLU = 'L'. */
/* The bidiagonal matrix has */
/* N = NL + NR + 1 rows and */
/* M = N + SQRE >= N columns. */
/* N (input) INTEGER */
/* On entry, N specifies the number of rows and columns */
/* in the matrix. N must be at least 0. */
/* NCVT (input) INTEGER */
/* On entry, NCVT specifies the number of columns of */
/* the matrix VT. NCVT must be at least 0. */
/* NRU (input) INTEGER */
/* On entry, NRU specifies the number of rows of */
/* the matrix U. NRU must be at least 0. */
/* NCC (input) INTEGER */
/* On entry, NCC specifies the number of columns of */
/* the matrix C. NCC must be at least 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, D contains the diagonal entries of the */
/* bidiagonal matrix whose SVD is desired. On normal exit, */
/* D contains the singular values in ascending order. */
/* E (input/output) DOUBLE PRECISION array. */
/* dimension is (N-1) if SQRE = 0 and N if SQRE = 1. */
/* On entry, the entries of E contain the offdiagonal entries */
/* of the bidiagonal matrix whose SVD is desired. On normal */
/* exit, E will contain 0. If the algorithm does not converge, */
/* D and E will contain the diagonal and superdiagonal entries */
/* of a bidiagonal matrix orthogonally equivalent to the one */
/* given as input. */
/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */
/* On entry, contains a matrix which on exit has been */
/* premultiplied by P', dimension N-by-NCVT if SQRE = 0 */
/* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). */
/* LDVT (input) INTEGER */
/* On entry, LDVT specifies the leading dimension of VT as */
/* declared in the calling (sub) program. LDVT must be at */
/* least 1. If NCVT is nonzero LDVT must also be at least N. */
/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */
/* On entry, contains a matrix which on exit has been */
/* postmultiplied by Q, dimension NRU-by-N if SQRE = 0 */
/* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). */
/* LDU (input) INTEGER */
/* On entry, LDU specifies the leading dimension of U as */
/* declared in the calling (sub) program. LDU must be at */
/* least max( 1, NRU ) . */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */
/* On entry, contains an N-by-NCC matrix which on exit */
/* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 */
/* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). */
/* LDC (input) INTEGER */
/* On entry, LDC specifies the leading dimension of C as */
/* declared in the calling (sub) program. LDC must be at */
/* least 1. If NCC is nonzero, LDC must also be at least N. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
/* Workspace. Only referenced if one of NCVT, NRU, or NCC is */
/* nonzero, and if N is at least 2. */
/* INFO (output) INTEGER */
/* On exit, a value of 0 indicates a successful exit. */
/* If INFO < 0, argument number -INFO is illegal. */
/* If INFO > 0, the algorithm did not converge, and INFO */
/* specifies how many superdiagonals did not converge. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, 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;
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;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (iuplo == 0) {
*info = -1;
} else if (*sqre < 0 || *sqre > 1) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncvt < 0) {
*info = -4;
} else if (*nru < 0) {
*info = -5;
} else if (*ncc < 0) {
*info = -6;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -10;
} else if (*ldu < max(1,*nru)) {
*info = -12;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASDQ", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
np1 = *n + 1;
sqre1 = *sqre;
/* If matrix non-square upper bidiagonal, rotate to be lower */
/* bidiagonal. The rotations are on the right. */
if (iuplo == 1 && sqre1 == 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 (rotate) {
work[i__] = cs;
work[*n + i__] = sn;
}
/* L10: */
}
dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
d__[*n] = r__;
e[*n] = 0.;
if (rotate) {
work[*n] = cs;
work[*n + *n] = sn;
}
iuplo = 2;
sqre1 = 0;
/* Update singular vectors if desired. */
if (*ncvt > 0) {
dlasr_("L", "V", "F", &np1, ncvt, &work[1], &work[np1], &vt[
vt_offset], ldvt);
}
}
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left. */
if (iuplo == 2) {
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 (rotate) {
work[i__] = cs;
work[*n + i__] = sn;
}
/* L20: */
}
/* If matrix (N+1)-by-N lower bidiagonal, one additional */
/* rotation is needed. */
if (sqre1 == 1) {
dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
d__[*n] = r__;
if (rotate) {
work[*n] = cs;
work[*n + *n] = sn;
}
}
/* Update singular vectors if desired. */
if (*nru > 0) {
if (sqre1 == 0) {
dlasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[
u_offset], ldu);
} else {
dlasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[
u_offset], ldu);
}
}
if (*ncc > 0) {
if (sqre1 == 0) {
dlasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[
c_offset], ldc);
} else {
dlasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[
c_offset], ldc);
}
}
}
/* Call DBDSQR to compute the SVD of the reduced real */
/* N-by-N upper bidiagonal matrix. */
dbdsqr_("U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[
u_offset], ldu, &c__[c_offset], ldc, &work[1], info);
/* Sort the singular values into ascending order (insertion sort on */
/* singular values, but only one transposition per singular vector) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I). */
isub = i__;
smin = d__[i__];
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (d__[j] < smin) {
isub = j;
smin = d__[j];
}
/* L30: */
}
if (isub != i__) {
/* Swap singular values and vectors. */
d__[isub] = d__[i__];
d__[i__] = smin;
if (*ncvt > 0) {
dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1],
ldvt);
}
if (*nru > 0) {
dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1]
, &c__1);
}
if (*ncc > 0) {
dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc)
;
}
}
/* L40: */
}
return 0;
/* End of DLASDQ */
} /* dlasdq_ */

136
3rdparty/lapack/dlasdt.c vendored
View File

@ -1,136 +0,0 @@
/* dlasdt.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 dlasdt_(integer *n, integer *lvl, integer *nd, integer *
inode, integer *ndiml, integer *ndimr, integer *msub)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer i__, il, ir, maxn;
doublereal temp;
integer nlvl, llst, ncrnt;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASDT creates a tree of subproblems for bidiagonal divide and */
/* conquer. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* On entry, the number of diagonal elements of the */
/* bidiagonal matrix. */
/* LVL (output) INTEGER */
/* On exit, the number of levels on the computation tree. */
/* ND (output) INTEGER */
/* On exit, the number of nodes on the tree. */
/* INODE (output) INTEGER array, dimension ( N ) */
/* On exit, centers of subproblems. */
/* NDIML (output) INTEGER array, dimension ( N ) */
/* On exit, row dimensions of left children. */
/* NDIMR (output) INTEGER array, dimension ( N ) */
/* On exit, row dimensions of right children. */
/* MSUB (input) INTEGER. */
/* On entry, the maximum row dimension each subproblem at the */
/* bottom of the tree can be of. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Find the number of levels on the tree. */
/* Parameter adjustments */
--ndimr;
--ndiml;
--inode;
/* Function Body */
maxn = max(1,*n);
temp = log((doublereal) maxn / (doublereal) (*msub + 1)) / log(2.);
*lvl = (integer) temp + 1;
i__ = *n / 2;
inode[1] = i__ + 1;
ndiml[1] = i__;
ndimr[1] = *n - i__ - 1;
il = 0;
ir = 1;
llst = 1;
i__1 = *lvl - 1;
for (nlvl = 1; nlvl <= i__1; ++nlvl) {
/* Constructing the tree at (NLVL+1)-st level. The number of */
/* nodes created on this level is LLST * 2. */
i__2 = llst - 1;
for (i__ = 0; i__ <= i__2; ++i__) {
il += 2;
ir += 2;
ncrnt = llst + i__;
ndiml[il] = ndiml[ncrnt] / 2;
ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1;
inode[il] = inode[ncrnt] - ndimr[il] - 1;
ndiml[ir] = ndimr[ncrnt] / 2;
ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1;
inode[ir] = inode[ncrnt] + ndiml[ir] + 1;
/* L10: */
}
llst <<= 1;
/* L20: */
}
*nd = (llst << 1) - 1;
return 0;
/* End of DLASDT */
} /* dlasdt_ */

152
3rdparty/lapack/dlaset.c vendored
View File

@ -1,152 +0,0 @@
/* dlaset.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 dlaset_(char *uplo, integer *m, integer *n, doublereal *
alpha, doublereal *beta, doublereal *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* 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 */
/* ======= */
/* DLASET initializes an m-by-n matrix A to BETA on the diagonal and */
/* ALPHA on the offdiagonals. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies the part of the matrix A to be set. */
/* = 'U': Upper triangular part is set; the strictly lower */
/* triangular part of A is not changed. */
/* = 'L': Lower triangular part is set; the strictly upper */
/* triangular part of A is not changed. */
/* Otherwise: All of the matrix A is set. */
/* 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. */
/* ALPHA (input) DOUBLE PRECISION */
/* The constant to which the offdiagonal elements are to be set. */
/* BETA (input) DOUBLE PRECISION */
/* The constant to which the diagonal elements are to be set. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On exit, the leading m-by-n submatrix of A is set as follows: */
/* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */
/* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */
/* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */
/* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
if (lsame_(uplo, "U")) {
/* Set the strictly upper triangular or trapezoidal part of the */
/* array to ALPHA. */
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L10: */
}
/* L20: */
}
} else if (lsame_(uplo, "L")) {
/* Set the strictly lower triangular or trapezoidal part of the */
/* array to ALPHA. */
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L30: */
}
/* L40: */
}
} else {
/* Set the leading m-by-n submatrix to ALPHA. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L50: */
}
/* L60: */
}
}
/* Set the first min(M,N) diagonal elements to BETA. */
i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + i__ * a_dim1] = *beta;
/* L70: */
}
return 0;
/* End of DLASET */
} /* dlaset_ */

219
3rdparty/lapack/dlasq1.c vendored
View File

@ -1,219 +0,0 @@
/* dlasq1.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;
static integer c__0 = 0;
/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e,
doublereal *work, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal eps;
extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
doublereal scale;
integer iinfo;
doublereal sigmn;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal sigmx;
extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), dlasrt_(
char *, integer *, doublereal *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ1 computes the singular values of a real N-by-N bidiagonal */
/* matrix with diagonal D and off-diagonal E. The singular values */
/* are computed to high relative accuracy, in the absence of */
/* denormalization, underflow and overflow. The algorithm was first */
/* presented in */
/* "Accurate singular values and differential qd algorithms" by K. V. */
/* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, */
/* 1994, */
/* and the present implementation is described in "An implementation of */
/* the dqds Algorithm (Positive Case)", LAPACK Working Note. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows and columns in the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, D contains the diagonal elements of the */
/* bidiagonal matrix whose SVD is desired. On normal exit, */
/* D contains the singular values in decreasing order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, elements E(1:N-1) contain the off-diagonal elements */
/* of the bidiagonal matrix whose SVD is desired. */
/* On exit, E is overwritten. */
/* 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: the algorithm failed */
/* = 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) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--e;
--d__;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
i__1 = -(*info);
xerbla_("DLASQ1", &i__1);
return 0;
} else if (*n == 0) {
return 0;
} else if (*n == 1) {
d__[1] = abs(d__[1]);
return 0;
} else if (*n == 2) {
dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx);
d__[1] = sigmx;
d__[2] = sigmn;
return 0;
}
/* Estimate the largest singular value. */
sigmx = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* Computing MAX */
d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1));
sigmx = max(d__2,d__3);
/* L10: */
}
d__[*n] = (d__1 = d__[*n], abs(d__1));
/* Early return if SIGMX is zero (matrix is already diagonal). */
if (sigmx == 0.) {
dlasrt_("D", n, &d__[1], &iinfo);
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = sigmx, d__2 = d__[i__];
sigmx = max(d__1,d__2);
/* L20: */
}
/* Copy D and E into WORK (in the Z format) and scale (squaring the */
/* input data makes scaling by a power of the radix pointless). */
eps = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
scale = sqrt(eps / safmin);
dcopy_(n, &d__[1], &c__1, &work[1], &c__2);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2);
i__1 = (*n << 1) - 1;
i__2 = (*n << 1) - 1;
dlascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2,
&iinfo);
/* Compute the q's and e's. */
i__1 = (*n << 1) - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing 2nd power */
d__1 = work[i__];
work[i__] = d__1 * d__1;
/* L30: */
}
work[*n * 2] = 0.;
dlasq2_(n, &work[1], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(work[i__]);
/* L40: */
}
dlascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
iinfo);
}
return 0;
/* End of DLASQ1 */
} /* dlasq1_ */

602
3rdparty/lapack/dlasq2.c vendored
View File

@ -1,602 +0,0 @@
/* dlasq2.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;
static integer c__10 = 10;
static integer c__3 = 3;
static integer c__4 = 4;
static integer c__11 = 11;
/* Subroutine */ int dlasq2_(integer *n, doublereal *z__, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal d__, e, g;
integer k;
doublereal s, t;
integer i0, i4, n0;
doublereal dn;
integer pp;
doublereal dn1, dn2, dee, eps, tau, tol;
integer ipn4;
doublereal tol2;
logical ieee;
integer nbig;
doublereal dmin__, emin, emax;
integer kmin, ndiv, iter;
doublereal qmin, temp, qmax, zmax;
integer splt;
doublereal dmin1, dmin2;
integer nfail;
doublereal desig, trace, sigma;
integer iinfo, ttype;
extern /* Subroutine */ int dlasq3_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *, logical *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
doublereal deemin;
integer iwhila, iwhilb;
doublereal oldemn, safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ2 computes all the eigenvalues of the symmetric positive */
/* definite tridiagonal matrix associated with the qd array Z to high */
/* relative accuracy are computed to high relative accuracy, in the */
/* absence of denormalization, underflow and overflow. */
/* To see the relation of Z to the tridiagonal matrix, let L be a */
/* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and */
/* let U be an upper bidiagonal matrix with 1's above and diagonal */
/* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the */
/* symmetric tridiagonal to which it is similar. */
/* Note : DLASQ2 defines a logical variable, IEEE, which is true */
/* on machines which follow ieee-754 floating-point standard in their */
/* handling of infinities and NaNs, and false otherwise. This variable */
/* is passed to DLASQ3. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows and columns in the matrix. N >= 0. */
/* Z (input/output) DOUBLE PRECISION array, dimension ( 4*N ) */
/* On entry Z holds the qd array. On exit, entries 1 to N hold */
/* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the */
/* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If */
/* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) */
/* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of */
/* shifts that failed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if the i-th argument is a scalar and had an illegal */
/* value, then INFO = -i, if the i-th argument is an */
/* array and the j-entry had an illegal value, then */
/* INFO = -(i*100+j) */
/* > 0: the algorithm failed */
/* = 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) */
/* Further Details */
/* =============== */
/* Local Variables: I0:N0 defines a current unreduced segment of Z. */
/* The shifts are accumulated in SIGMA. Iteration count is in ITER. */
/* Ping-pong is controlled by PP (alternates between 0 and 1). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* (in case DLASQ2 is not called by DLASQ1) */
/* Parameter adjustments */
--z__;
/* Function Body */
*info = 0;
eps = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
tol = eps * 100.;
/* Computing 2nd power */
d__1 = tol;
tol2 = d__1 * d__1;
if (*n < 0) {
*info = -1;
xerbla_("DLASQ2", &c__1);
return 0;
} else if (*n == 0) {
return 0;
} else if (*n == 1) {
/* 1-by-1 case. */
if (z__[1] < 0.) {
*info = -201;
xerbla_("DLASQ2", &c__2);
}
return 0;
} else if (*n == 2) {
/* 2-by-2 case. */
if (z__[2] < 0. || z__[3] < 0.) {
*info = -2;
xerbla_("DLASQ2", &c__2);
return 0;
} else if (z__[3] > z__[1]) {
d__ = z__[3];
z__[3] = z__[1];
z__[1] = d__;
}
z__[5] = z__[1] + z__[2] + z__[3];
if (z__[2] > z__[3] * tol2) {
t = (z__[1] - z__[3] + z__[2]) * .5;
s = z__[3] * (z__[2] / t);
if (s <= t) {
s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.)));
} else {
s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s)));
}
t = z__[1] + (s + z__[2]);
z__[3] *= z__[1] / t;
z__[1] = t;
}
z__[2] = z__[3];
z__[6] = z__[2] + z__[1];
return 0;
}
/* Check for negative data and compute sums of q's and e's. */
z__[*n * 2] = 0.;
emin = z__[2];
qmax = 0.;
zmax = 0.;
d__ = 0.;
e = 0.;
i__1 = *n - 1 << 1;
for (k = 1; k <= i__1; k += 2) {
if (z__[k] < 0.) {
*info = -(k + 200);
xerbla_("DLASQ2", &c__2);
return 0;
} else if (z__[k + 1] < 0.) {
*info = -(k + 201);
xerbla_("DLASQ2", &c__2);
return 0;
}
d__ += z__[k];
e += z__[k + 1];
/* Computing MAX */
d__1 = qmax, d__2 = z__[k];
qmax = max(d__1,d__2);
/* Computing MIN */
d__1 = emin, d__2 = z__[k + 1];
emin = min(d__1,d__2);
/* Computing MAX */
d__1 = max(qmax,zmax), d__2 = z__[k + 1];
zmax = max(d__1,d__2);
/* L10: */
}
if (z__[(*n << 1) - 1] < 0.) {
*info = -((*n << 1) + 199);
xerbla_("DLASQ2", &c__2);
return 0;
}
d__ += z__[(*n << 1) - 1];
/* Computing MAX */
d__1 = qmax, d__2 = z__[(*n << 1) - 1];
qmax = max(d__1,d__2);
zmax = max(qmax,zmax);
/* Check for diagonality. */
if (e == 0.) {
i__1 = *n;
for (k = 2; k <= i__1; ++k) {
z__[k] = z__[(k << 1) - 1];
/* L20: */
}
dlasrt_("D", n, &z__[1], &iinfo);
z__[(*n << 1) - 1] = d__;
return 0;
}
trace = d__ + e;
/* Check for zero data. */
if (trace == 0.) {
z__[(*n << 1) - 1] = 0.;
return 0;
}
/* Check whether the machine is IEEE conformable. */
ieee = ilaenv_(&c__10, "DLASQ2", "N", &c__1, &c__2, &c__3, &c__4) == 1 && ilaenv_(&c__11, "DLASQ2", "N", &c__1, &c__2,
&c__3, &c__4) == 1;
/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */
for (k = *n << 1; k >= 2; k += -2) {
z__[k * 2] = 0.;
z__[(k << 1) - 1] = z__[k];
z__[(k << 1) - 2] = 0.;
z__[(k << 1) - 3] = z__[k - 1];
/* L30: */
}
i0 = 1;
n0 = *n;
/* Reverse the qd-array, if warranted. */
if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) {
ipn4 = i0 + n0 << 2;
i__1 = i0 + n0 - 1 << 1;
for (i4 = i0 << 2; i4 <= i__1; i4 += 4) {
temp = z__[i4 - 3];
z__[i4 - 3] = z__[ipn4 - i4 - 3];
z__[ipn4 - i4 - 3] = temp;
temp = z__[i4 - 1];
z__[i4 - 1] = z__[ipn4 - i4 - 5];
z__[ipn4 - i4 - 5] = temp;
/* L40: */
}
}
/* Initial split checking via dqd and Li's test. */
pp = 0;
for (k = 1; k <= 2; ++k) {
d__ = z__[(n0 << 2) + pp - 3];
i__1 = (i0 << 2) + pp;
for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) {
if (z__[i4 - 1] <= tol2 * d__) {
z__[i4 - 1] = -0.;
d__ = z__[i4 - 3];
} else {
d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1]));
}
/* L50: */
}
/* dqd maps Z to ZZ plus Li's test. */
emin = z__[(i0 << 2) + pp + 1];
d__ = z__[(i0 << 2) + pp - 3];
i__1 = (n0 - 1 << 2) + pp;
for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) {
z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1];
if (z__[i4 - 1] <= tol2 * d__) {
z__[i4 - 1] = -0.;
z__[i4 - (pp << 1) - 2] = d__;
z__[i4 - (pp << 1)] = 0.;
d__ = z__[i4 + 1];
} else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] &&
safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) {
temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2];
z__[i4 - (pp << 1)] = z__[i4 - 1] * temp;
d__ *= temp;
} else {
z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (
pp << 1) - 2]);
d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]);
}
/* Computing MIN */
d__1 = emin, d__2 = z__[i4 - (pp << 1)];
emin = min(d__1,d__2);
/* L60: */
}
z__[(n0 << 2) - pp - 2] = d__;
/* Now find qmax. */
qmax = z__[(i0 << 2) - pp - 2];
i__1 = (n0 << 2) - pp - 2;
for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) {
/* Computing MAX */
d__1 = qmax, d__2 = z__[i4];
qmax = max(d__1,d__2);
/* L70: */
}
/* Prepare for the next iteration on K. */
pp = 1 - pp;
/* L80: */
}
/* Initialise variables to pass to DLASQ3. */
ttype = 0;
dmin1 = 0.;
dmin2 = 0.;
dn = 0.;
dn1 = 0.;
dn2 = 0.;
g = 0.;
tau = 0.;
iter = 2;
nfail = 0;
ndiv = n0 - i0 << 1;
i__1 = *n + 1;
for (iwhila = 1; iwhila <= i__1; ++iwhila) {
if (n0 < 1) {
goto L170;
}
/* While array unfinished do */
/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */
/* splits from the rest of the array, but is negated. */
desig = 0.;
if (n0 == *n) {
sigma = 0.;
} else {
sigma = -z__[(n0 << 2) - 1];
}
if (sigma < 0.) {
*info = 1;
return 0;
}
/* Find last unreduced submatrix's top index I0, find QMAX and */
/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */
emax = 0.;
if (n0 > i0) {
emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1));
} else {
emin = 0.;
}
qmin = z__[(n0 << 2) - 3];
qmax = qmin;
for (i4 = n0 << 2; i4 >= 8; i4 += -4) {
if (z__[i4 - 5] <= 0.) {
goto L100;
}
if (qmin >= emax * 4.) {
/* Computing MIN */
d__1 = qmin, d__2 = z__[i4 - 3];
qmin = min(d__1,d__2);
/* Computing MAX */
d__1 = emax, d__2 = z__[i4 - 5];
emax = max(d__1,d__2);
}
/* Computing MAX */
d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5];
qmax = max(d__1,d__2);
/* Computing MIN */
d__1 = emin, d__2 = z__[i4 - 5];
emin = min(d__1,d__2);
/* L90: */
}
i4 = 4;
L100:
i0 = i4 / 4;
pp = 0;
if (n0 - i0 > 1) {
dee = z__[(i0 << 2) - 3];
deemin = dee;
kmin = i0;
i__2 = (n0 << 2) - 3;
for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) {
dee = z__[i4] * (dee / (dee + z__[i4 - 2]));
if (dee <= deemin) {
deemin = dee;
kmin = (i4 + 3) / 4;
}
/* L110: */
}
if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] *
.5) {
ipn4 = i0 + n0 << 2;
pp = 2;
i__2 = i0 + n0 - 1 << 1;
for (i4 = i0 << 2; i4 <= i__2; i4 += 4) {
temp = z__[i4 - 3];
z__[i4 - 3] = z__[ipn4 - i4 - 3];
z__[ipn4 - i4 - 3] = temp;
temp = z__[i4 - 2];
z__[i4 - 2] = z__[ipn4 - i4 - 2];
z__[ipn4 - i4 - 2] = temp;
temp = z__[i4 - 1];
z__[i4 - 1] = z__[ipn4 - i4 - 5];
z__[ipn4 - i4 - 5] = temp;
temp = z__[i4];
z__[i4] = z__[ipn4 - i4 - 4];
z__[ipn4 - i4 - 4] = temp;
/* L120: */
}
}
}
/* Put -(initial shift) into DMIN. */
/* Computing MAX */
d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax);
dmin__ = -max(d__1,d__2);
/* Now I0:N0 is unreduced. */
/* PP = 0 for ping, PP = 1 for pong. */
/* PP = 2 indicates that flipping was applied to the Z array and */
/* and that the tests for deflation upon entry in DLASQ3 */
/* should not be performed. */
nbig = (n0 - i0 + 1) * 30;
i__2 = nbig;
for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) {
if (i0 > n0) {
goto L150;
}
/* While submatrix unfinished take a good dqds step. */
dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &
nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &
dn1, &dn2, &g, &tau);
pp = 1 - pp;
/* When EMIN is very small check for splits. */
if (pp == 0 && n0 - i0 >= 3) {
if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 *
sigma) {
splt = i0 - 1;
qmax = z__[(i0 << 2) - 3];
emin = z__[(i0 << 2) - 1];
oldemn = z__[i0 * 4];
i__3 = n0 - 3 << 2;
for (i4 = i0 << 2; i4 <= i__3; i4 += 4) {
if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <=
tol2 * sigma) {
z__[i4 - 1] = -sigma;
splt = i4 / 4;
qmax = 0.;
emin = z__[i4 + 3];
oldemn = z__[i4 + 4];
} else {
/* Computing MAX */
d__1 = qmax, d__2 = z__[i4 + 1];
qmax = max(d__1,d__2);
/* Computing MIN */
d__1 = emin, d__2 = z__[i4 - 1];
emin = min(d__1,d__2);
/* Computing MIN */
d__1 = oldemn, d__2 = z__[i4];
oldemn = min(d__1,d__2);
}
/* L130: */
}
z__[(n0 << 2) - 1] = emin;
z__[n0 * 4] = oldemn;
i0 = splt + 1;
}
}
/* L140: */
}
*info = 2;
return 0;
/* end IWHILB */
L150:
/* L160: */
;
}
*info = 3;
return 0;
/* end IWHILA */
L170:
/* Move q's to the front. */
i__1 = *n;
for (k = 2; k <= i__1; ++k) {
z__[k] = z__[(k << 2) - 3];
/* L180: */
}
/* Sort and compute sum of eigenvalues. */
dlasrt_("D", n, &z__[1], &iinfo);
e = 0.;
for (k = *n; k >= 1; --k) {
e += z__[k];
/* L190: */
}
/* Store trace, sum(eigenvalues) and information on performance. */
z__[(*n << 1) + 1] = trace;
z__[(*n << 1) + 2] = e;
z__[(*n << 1) + 3] = (doublereal) iter;
/* Computing 2nd power */
i__1 = *n;
z__[(*n << 1) + 4] = (doublereal) ndiv / (doublereal) (i__1 * i__1);
z__[(*n << 1) + 5] = nfail * 100. / (doublereal) iter;
return 0;
/* End of DLASQ2 */
} /* dlasq2_ */

350
3rdparty/lapack/dlasq3.c vendored
View File

@ -1,350 +0,0 @@
/* dlasq3.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 dlasq3_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig,
doublereal *qmax, integer *nfail, integer *iter, integer *ndiv,
logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g,
doublereal *tau)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal s, t;
integer j4, nn;
doublereal eps, tol;
integer n0in, ipn4;
doublereal tol2, temp;
extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *), dlasq5_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, logical *), dlasq6_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
extern logical disnan_(doublereal *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */
/* In case of failure it changes shifts, and tries again until output */
/* is positive. */
/* Arguments */
/* ========= */
/* I0 (input) INTEGER */
/* First index. */
/* N0 (input) INTEGER */
/* Last index. */
/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
/* Z holds the qd array. */
/* PP (input/output) INTEGER */
/* PP=0 for ping, PP=1 for pong. */
/* PP=2 indicates that flipping was applied to the Z array */
/* and that the initial tests for deflation should not be */
/* performed. */
/* DMIN (output) DOUBLE PRECISION */
/* Minimum value of d. */
/* SIGMA (output) DOUBLE PRECISION */
/* Sum of shifts used in current segment. */
/* DESIG (input/output) DOUBLE PRECISION */
/* Lower order part of SIGMA */
/* QMAX (input) DOUBLE PRECISION */
/* Maximum value of q. */
/* NFAIL (output) INTEGER */
/* Number of times shift was too big. */
/* ITER (output) INTEGER */
/* Number of iterations. */
/* NDIV (output) INTEGER */
/* Number of divisions. */
/* IEEE (input) LOGICAL */
/* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). */
/* TTYPE (input/output) INTEGER */
/* Shift type. */
/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) DOUBLE PRECISION */
/* These are passed as arguments in order to save their values */
/* between calls to DLASQ3. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
n0in = *n0;
eps = dlamch_("Precision");
tol = eps * 100.;
/* Computing 2nd power */
d__1 = tol;
tol2 = d__1 * d__1;
/* Check for deflation. */
L10:
if (*n0 < *i0) {
return 0;
}
if (*n0 == *i0) {
goto L20;
}
nn = (*n0 << 2) + *pp;
if (*n0 == *i0 + 1) {
goto L40;
}
/* Check whether E(N0-1) is negligible, 1 eigenvalue. */
if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) -
4] > tol2 * z__[nn - 7]) {
goto L30;
}
L20:
z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
--(*n0);
goto L10;
/* Check whether E(N0-2) is negligible, 2 eigenvalues. */
L30:
if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
nn - 11]) {
goto L50;
}
L40:
if (z__[nn - 3] > z__[nn - 7]) {
s = z__[nn - 3];
z__[nn - 3] = z__[nn - 7];
z__[nn - 7] = s;
}
if (z__[nn - 5] > z__[nn - 3] * tol2) {
t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5;
s = z__[nn - 3] * (z__[nn - 5] / t);
if (s <= t) {
s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.)));
} else {
s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
}
t = z__[nn - 7] + (s + z__[nn - 5]);
z__[nn - 3] *= z__[nn - 7] / t;
z__[nn - 7] = t;
}
z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
*n0 += -2;
goto L10;
L50:
if (*pp == 2) {
*pp = 0;
}
/* Reverse the qd-array, if warranted. */
if (*dmin__ <= 0. || *n0 < n0in) {
if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) {
ipn4 = *i0 + *n0 << 2;
i__1 = *i0 + *n0 - 1 << 1;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
temp = z__[j4 - 3];
z__[j4 - 3] = z__[ipn4 - j4 - 3];
z__[ipn4 - j4 - 3] = temp;
temp = z__[j4 - 2];
z__[j4 - 2] = z__[ipn4 - j4 - 2];
z__[ipn4 - j4 - 2] = temp;
temp = z__[j4 - 1];
z__[j4 - 1] = z__[ipn4 - j4 - 5];
z__[ipn4 - j4 - 5] = temp;
temp = z__[j4];
z__[j4] = z__[ipn4 - j4 - 4];
z__[ipn4 - j4 - 4] = temp;
/* L60: */
}
if (*n0 - *i0 <= 4) {
z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
}
/* Computing MIN */
d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1];
*dmin2 = min(d__1,d__2);
/* Computing MIN */
d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1]
, d__1 = min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3];
z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2);
/* Computing MIN */
d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 =
min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4];
z__[(*n0 << 2) - *pp] = min(d__1,d__2);
/* Computing MAX */
d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1,
d__2), d__2 = z__[(*i0 << 2) + *pp + 1];
*qmax = max(d__1,d__2);
*dmin__ = -0.;
}
}
/* Choose a shift. */
dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2,
tau, ttype, g);
/* Call dqds until DMIN > 0. */
L70:
dlasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2,
ieee);
*ndiv += *n0 - *i0 + 2;
++(*iter);
/* Check status. */
if (*dmin__ >= 0. && *dmin1 > 0.) {
/* Success. */
goto L90;
} else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol
* (*sigma + *dn1) && abs(*dn) < tol * *sigma) {
/* Convergence hidden by negative DN. */
z__[(*n0 - 1 << 2) - *pp + 2] = 0.;
*dmin__ = 0.;
goto L90;
} else if (*dmin__ < 0.) {
/* TAU too big. Select new TAU and try again. */
++(*nfail);
if (*ttype < -22) {
/* Failed twice. Play it safe. */
*tau = 0.;
} else if (*dmin1 > 0.) {
/* Late failure. Gives excellent shift. */
*tau = (*tau + *dmin__) * (1. - eps * 2.);
*ttype += -11;
} else {
/* Early failure. Divide by 4. */
*tau *= .25;
*ttype += -12;
}
goto L70;
} else if (disnan_(dmin__)) {
/* NaN. */
if (*tau == 0.) {
goto L80;
} else {
*tau = 0.;
goto L70;
}
} else {
/* Possible underflow. Play it safe. */
goto L80;
}
/* Risk of underflow. */
L80:
dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
*ndiv += *n0 - *i0 + 2;
++(*iter);
*tau = 0.;
L90:
if (*tau < *sigma) {
*desig += *tau;
t = *sigma + *desig;
*desig -= t - *sigma;
} else {
t = *sigma + *tau;
*desig = *sigma - (t - *tau) + *desig;
}
*sigma = t;
return 0;
/* End of DLASQ3 */
} /* dlasq3_ */

403
3rdparty/lapack/dlasq4.c vendored
View File

@ -1,403 +0,0 @@
/* dlasq4.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 dlasq4_(integer *i0, integer *n0, doublereal *z__,
integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1,
doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2,
doublereal *tau, integer *ttype, doublereal *g)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal s, a2, b1, b2;
integer i4, nn, np;
doublereal gam, gap1, gap2;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ4 computes an approximation TAU to the smallest eigenvalue */
/* using values of d from the previous transform. */
/* I0 (input) INTEGER */
/* First index. */
/* N0 (input) INTEGER */
/* Last index. */
/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
/* Z holds the qd array. */
/* PP (input) INTEGER */
/* PP=0 for ping, PP=1 for pong. */
/* NOIN (input) INTEGER */
/* The value of N0 at start of EIGTEST. */
/* DMIN (input) DOUBLE PRECISION */
/* Minimum value of d. */
/* DMIN1 (input) DOUBLE PRECISION */
/* Minimum value of d, excluding D( N0 ). */
/* DMIN2 (input) DOUBLE PRECISION */
/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* DN (input) DOUBLE PRECISION */
/* d(N) */
/* DN1 (input) DOUBLE PRECISION */
/* d(N-1) */
/* DN2 (input) DOUBLE PRECISION */
/* d(N-2) */
/* TAU (output) DOUBLE PRECISION */
/* This is the shift. */
/* TTYPE (output) INTEGER */
/* Shift type. */
/* G (input/output) REAL */
/* G is passed as an argument in order to save its value between */
/* calls to DLASQ4. */
/* Further Details */
/* =============== */
/* CNST1 = 9/16 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* A negative DMIN forces the shift to take that absolute value */
/* TTYPE records the type of shift. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*dmin__ <= 0.) {
*tau = -(*dmin__);
*ttype = -1;
return 0;
}
nn = (*n0 << 2) + *pp;
if (*n0in == *n0) {
/* No eigenvalues deflated. */
if (*dmin__ == *dn || *dmin__ == *dn1) {
b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
a2 = z__[nn - 7] + z__[nn - 5];
/* Cases 2 and 3. */
if (*dmin__ == *dn && *dmin1 == *dn1) {
gap2 = *dmin2 - a2 - *dmin2 * .25;
if (gap2 > 0. && gap2 > b2) {
gap1 = a2 - *dn - b2 / gap2 * b2;
} else {
gap1 = a2 - *dn - (b1 + b2);
}
if (gap1 > 0. && gap1 > b1) {
/* Computing MAX */
d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5;
s = max(d__1,d__2);
*ttype = -2;
} else {
s = 0.;
if (*dn > b1) {
s = *dn - b1;
}
if (a2 > b1 + b2) {
/* Computing MIN */
d__1 = s, d__2 = a2 - (b1 + b2);
s = min(d__1,d__2);
}
/* Computing MAX */
d__1 = s, d__2 = *dmin__ * .333;
s = max(d__1,d__2);
*ttype = -3;
}
} else {
/* Case 4. */
*ttype = -4;
s = *dmin__ * .25;
if (*dmin__ == *dn) {
gam = *dn;
a2 = 0.;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b2 = z__[nn - 5] / z__[nn - 7];
np = nn - 9;
} else {
np = nn - (*pp << 1);
b2 = z__[np - 2];
gam = *dn1;
if (z__[np - 4] > z__[np - 2]) {
return 0;
}
a2 = z__[np - 4] / z__[np - 2];
if (z__[nn - 9] > z__[nn - 11]) {
return 0;
}
b2 = z__[nn - 9] / z__[nn - 11];
np = nn - 13;
}
/* Approximate contribution to norm squared from I < NN-1. */
a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = np; i4 >= i__1; i4 += -4) {
if (b2 == 0.) {
goto L20;
}
b1 = b2;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b2 *= z__[i4] / z__[i4 - 2];
a2 += b2;
if (max(b2,b1) * 100. < a2 || .563 < a2) {
goto L20;
}
/* L10: */
}
L20:
a2 *= 1.05;
/* Rayleigh quotient residual bound. */
if (a2 < .563) {
s = gam * (1. - sqrt(a2)) / (a2 + 1.);
}
}
} else if (*dmin__ == *dn2) {
/* Case 5. */
*ttype = -5;
s = *dmin__ * .25;
/* Compute contribution to norm squared from I > NN-2. */
np = nn - (*pp << 1);
b1 = z__[np - 2];
b2 = z__[np - 6];
gam = *dn2;
if (z__[np - 8] > b2 || z__[np - 4] > b1) {
return 0;
}
a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.);
/* Approximate contribution to norm squared from I < NN-2. */
if (*n0 - *i0 > 2) {
b2 = z__[nn - 13] / z__[nn - 15];
a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
if (b2 == 0.) {
goto L40;
}
b1 = b2;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b2 *= z__[i4] / z__[i4 - 2];
a2 += b2;
if (max(b2,b1) * 100. < a2 || .563 < a2) {
goto L40;
}
/* L30: */
}
L40:
a2 *= 1.05;
}
if (a2 < .563) {
s = gam * (1. - sqrt(a2)) / (a2 + 1.);
}
} else {
/* Case 6, no information to guide us. */
if (*ttype == -6) {
*g += (1. - *g) * .333;
} else if (*ttype == -18) {
*g = .083250000000000005;
} else {
*g = .25;
}
s = *g * *dmin__;
*ttype = -6;
}
} else if (*n0in == *n0 + 1) {
/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
if (*dmin1 == *dn1 && *dmin2 == *dn2) {
/* Cases 7 and 8. */
*ttype = -7;
s = *dmin1 * .333;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b1 = z__[nn - 5] / z__[nn - 7];
b2 = b1;
if (b2 == 0.) {
goto L60;
}
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
a2 = b1;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b1 *= z__[i4] / z__[i4 - 2];
b2 += b1;
if (max(b1,a2) * 100. < b2) {
goto L60;
}
/* L50: */
}
L60:
b2 = sqrt(b2 * 1.05);
/* Computing 2nd power */
d__1 = b2;
a2 = *dmin1 / (d__1 * d__1 + 1.);
gap2 = *dmin2 * .5 - a2;
if (gap2 > 0. && gap2 > b2 * a2) {
/* Computing MAX */
d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
s = max(d__1,d__2);
} else {
/* Computing MAX */
d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
s = max(d__1,d__2);
*ttype = -8;
}
} else {
/* Case 9. */
s = *dmin1 * .25;
if (*dmin1 == *dn1) {
s = *dmin1 * .5;
}
*ttype = -9;
}
} else if (*n0in == *n0 + 2) {
/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */
/* Cases 10 and 11. */
if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) {
*ttype = -10;
s = *dmin2 * .333;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b1 = z__[nn - 5] / z__[nn - 7];
b2 = b1;
if (b2 == 0.) {
goto L80;
}
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b1 *= z__[i4] / z__[i4 - 2];
b2 += b1;
if (b1 * 100. < b2) {
goto L80;
}
/* L70: */
}
L80:
b2 = sqrt(b2 * 1.05);
/* Computing 2nd power */
d__1 = b2;
a2 = *dmin2 / (d__1 * d__1 + 1.);
gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
nn - 9]) - a2;
if (gap2 > 0. && gap2 > b2 * a2) {
/* Computing MAX */
d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
s = max(d__1,d__2);
} else {
/* Computing MAX */
d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
s = max(d__1,d__2);
}
} else {
s = *dmin2 * .25;
*ttype = -11;
}
} else if (*n0in > *n0 + 2) {
/* Case 12, more than two eigenvalues deflated. No information. */
s = 0.;
*ttype = -12;
}
*tau = s;
return 0;
/* End of DLASQ4 */
} /* dlasq4_ */

240
3rdparty/lapack/dlasq5.c vendored
View File

@ -1,240 +0,0 @@
/* dlasq5.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 dlasq5_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *tau, doublereal *dmin__, doublereal *dmin1,
doublereal *dmin2, doublereal *dn, doublereal *dnm1, doublereal *dnm2,
logical *ieee)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal d__;
integer j4, j4p2;
doublereal emin, temp;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ5 computes one dqds transform in ping-pong form, one */
/* version for IEEE machines another for non IEEE machines. */
/* Arguments */
/* ========= */
/* I0 (input) INTEGER */
/* First index. */
/* N0 (input) INTEGER */
/* Last index. */
/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
/* an extra argument. */
/* PP (input) INTEGER */
/* PP=0 for ping, PP=1 for pong. */
/* TAU (input) DOUBLE PRECISION */
/* This is the shift. */
/* DMIN (output) DOUBLE PRECISION */
/* Minimum value of d. */
/* DMIN1 (output) DOUBLE PRECISION */
/* Minimum value of d, excluding D( N0 ). */
/* DMIN2 (output) DOUBLE PRECISION */
/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* DN (output) DOUBLE PRECISION */
/* d(N0), the last value of d. */
/* DNM1 (output) DOUBLE PRECISION */
/* d(N0-1). */
/* DNM2 (output) DOUBLE PRECISION */
/* d(N0-2). */
/* IEEE (input) LOGICAL */
/* Flag for IEEE or non IEEE arithmetic. */
/* ===================================================================== */
/* .. Parameter .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*n0 - *i0 - 1 <= 0) {
return 0;
}
j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4];
d__ = z__[j4] - *tau;
*dmin__ = d__;
*dmin1 = -z__[j4];
if (*ieee) {
/* Code for IEEE arithmetic. */
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1];
temp = z__[j4 + 1] / z__[j4 - 2];
d__ = d__ * temp - *tau;
*dmin__ = min(*dmin__,d__);
z__[j4] = z__[j4 - 1] * temp;
/* Computing MIN */
d__1 = z__[j4];
emin = min(d__1,emin);
/* L10: */
}
} else {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4];
temp = z__[j4 + 2] / z__[j4 - 3];
d__ = d__ * temp - *tau;
*dmin__ = min(*dmin__,d__);
z__[j4 - 1] = z__[j4] * temp;
/* Computing MIN */
d__1 = z__[j4 - 1];
emin = min(d__1,emin);
/* L20: */
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dn);
} else {
/* Code for non IEEE arithmetic. */
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1];
if (d__ < 0.) {
return 0;
} else {
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2);
/* L30: */
}
} else {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4];
if (d__ < 0.) {
return 0;
} else {
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau;
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2);
/* L40: */
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2];
if (*dnm2 < 0.) {
return 0;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
if (*dnm1 < 0.) {
return 0;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,*dn);
}
z__[j4 + 2] = *dn;
z__[(*n0 << 2) - *pp] = emin;
return 0;
/* End of DLASQ5 */
} /* dlasq5_ */

212
3rdparty/lapack/dlasq6.c vendored
View File

@ -1,212 +0,0 @@
/* dlasq6.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 dlasq6_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dnm1, doublereal *dnm2)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal d__;
integer j4, j4p2;
doublereal emin, temp;
extern doublereal dlamch_(char *);
doublereal safmin;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ6 computes one dqd (shift equal to zero) transform in */
/* ping-pong form, with protection against underflow and overflow. */
/* Arguments */
/* ========= */
/* I0 (input) INTEGER */
/* First index. */
/* N0 (input) INTEGER */
/* Last index. */
/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
/* an extra argument. */
/* PP (input) INTEGER */
/* PP=0 for ping, PP=1 for pong. */
/* DMIN (output) DOUBLE PRECISION */
/* Minimum value of d. */
/* DMIN1 (output) DOUBLE PRECISION */
/* Minimum value of d, excluding D( N0 ). */
/* DMIN2 (output) DOUBLE PRECISION */
/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* DN (output) DOUBLE PRECISION */
/* d(N0), the last value of d. */
/* DNM1 (output) DOUBLE PRECISION */
/* d(N0-1). */
/* DNM2 (output) DOUBLE PRECISION */
/* d(N0-2). */
/* ===================================================================== */
/* .. Parameter .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*n0 - *i0 - 1 <= 0) {
return 0;
}
safmin = dlamch_("Safe minimum");
j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4];
d__ = z__[j4];
*dmin__ = d__;
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
d__ = z__[j4 + 1];
*dmin__ = d__;
emin = 0.;
} else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4
- 2] < z__[j4 + 1]) {
temp = z__[j4 + 1] / z__[j4 - 2];
z__[j4] = z__[j4 - 1] * temp;
d__ *= temp;
} else {
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2);
/* L10: */
}
} else {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4];
if (z__[j4 - 3] == 0.) {
z__[j4 - 1] = 0.;
d__ = z__[j4 + 2];
*dmin__ = d__;
emin = 0.;
} else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4
- 3] < z__[j4 + 2]) {
temp = z__[j4 + 2] / z__[j4 - 3];
z__[j4 - 1] = z__[j4] * temp;
d__ *= temp;
} else {
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]);
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2);
/* L20: */
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
*dnm1 = z__[j4p2 + 2];
*dmin__ = *dnm1;
emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp;
*dnm1 = *dnm2 * temp;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
*dn = z__[j4p2 + 2];
*dmin__ = *dn;
emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp;
*dn = *dnm1 * temp;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,*dn);
z__[j4 + 2] = *dn;
z__[(*n0 << 2) - *pp] = emin;
return 0;
/* End of DLASQ6 */
} /* dlasq6_ */

453
3rdparty/lapack/dlasr_custom.c vendored
View File

@ -1,453 +0,0 @@
/* dlasr.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 dlasr_(char *side, char *pivot, char *direct, integer *m,
integer *n, doublereal *c__, doublereal *s, doublereal *a, integer *
lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, j, info;
doublereal temp;
extern logical lsame_(char *, char *);
doublereal ctemp, stemp;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASR applies a sequence of plane rotations to a real matrix A, */
/* from either the left or the right. */
/* When SIDE = 'L', the transformation takes the form */
/* A := P*A */
/* and when SIDE = 'R', the transformation takes the form */
/* A := A*P**T */
/* where P is an orthogonal matrix consisting of a sequence of z plane */
/* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */
/* and P**T is the transpose of P. */
/* When DIRECT = 'F' (Forward sequence), then */
/* P = P(z-1) * ... * P(2) * P(1) */
/* and when DIRECT = 'B' (Backward sequence), then */
/* P = P(1) * P(2) * ... * P(z-1) */
/* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */
/* R(k) = ( c(k) s(k) ) */
/* = ( -s(k) c(k) ). */
/* When PIVOT = 'V' (Variable pivot), the rotation is performed */
/* for the plane (k,k+1), i.e., P(k) has the form */
/* P(k) = ( 1 ) */
/* ( ... ) */
/* ( 1 ) */
/* ( c(k) s(k) ) */
/* ( -s(k) c(k) ) */
/* ( 1 ) */
/* ( ... ) */
/* ( 1 ) */
/* where R(k) appears as a rank-2 modification to the identity matrix in */
/* rows and columns k and k+1. */
/* When PIVOT = 'T' (Top pivot), the rotation is performed for the */
/* plane (1,k+1), so P(k) has the form */
/* P(k) = ( c(k) s(k) ) */
/* ( 1 ) */
/* ( ... ) */
/* ( 1 ) */
/* ( -s(k) c(k) ) */
/* ( 1 ) */
/* ( ... ) */
/* ( 1 ) */
/* where R(k) appears in rows and columns 1 and k+1. */
/* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */
/* performed for the plane (k,z), giving P(k) the form */
/* P(k) = ( 1 ) */
/* ( ... ) */
/* ( 1 ) */
/* ( c(k) s(k) ) */
/* ( 1 ) */
/* ( ... ) */
/* ( 1 ) */
/* ( -s(k) c(k) ) */
/* where R(k) appears in rows and columns k and z. The rotations are */
/* performed without ever forming P(k) explicitly. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* Specifies whether the plane rotation matrix P is applied to */
/* A on the left or the right. */
/* = 'L': Left, compute A := P*A */
/* = 'R': Right, compute A:= A*P**T */
/* PIVOT (input) CHARACTER*1 */
/* Specifies the plane for which P(k) is a plane rotation */
/* matrix. */
/* = 'V': Variable pivot, the plane (k,k+1) */
/* = 'T': Top pivot, the plane (1,k+1) */
/* = 'B': Bottom pivot, the plane (k,z) */
/* DIRECT (input) CHARACTER*1 */
/* Specifies whether P is a forward or backward sequence of */
/* plane rotations. */
/* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */
/* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */
/* M (input) INTEGER */
/* The number of rows of the matrix A. If m <= 1, an immediate */
/* return is effected. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. If n <= 1, an */
/* immediate return is effected. */
/* C (input) DOUBLE PRECISION array, dimension */
/* (M-1) if SIDE = 'L' */
/* (N-1) if SIDE = 'R' */
/* The cosines c(k) of the plane rotations. */
/* S (input) DOUBLE PRECISION array, dimension */
/* (M-1) if SIDE = 'L' */
/* (N-1) if SIDE = 'R' */
/* The sines s(k) of the plane rotations. The 2-by-2 plane */
/* rotation part of the matrix P(k), R(k), has the form */
/* R(k) = ( c(k) s(k) ) */
/* ( -s(k) c(k) ). */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* The M-by-N matrix A. On exit, A is overwritten by P*A if */
/* SIDE = 'R' or by A*P**T if SIDE = 'L'. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--c__;
--s;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
info = 0;
if (! (lsame_(side, "L") || lsame_(side, "R"))) {
info = 1;
} else if (! (lsame_(pivot, "V") || lsame_(pivot,
"T") || lsame_(pivot, "B"))) {
info = 2;
} else if (! (lsame_(direct, "F") || lsame_(direct,
"B"))) {
info = 3;
} else if (*m < 0) {
info = 4;
} else if (*n < 0) {
info = 5;
} else if (*lda < max(1,*m)) {
info = 9;
}
if (info != 0) {
xerbla_("DLASR ", &info);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
if (lsame_(side, "L")) {
/* Form P * A */
if (lsame_(pivot, "V")) {
if (lsame_(direct, "F")) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + 1 + i__ * a_dim1];
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ i__ * a_dim1];
/* L10: */
}
}
/* L20: */
}
} else if (lsame_(direct, "B")) {
for (j = *m - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + 1 + i__ * a_dim1];
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ i__ * a_dim1];
/* L30: */
}
}
/* L40: */
}
}
} else if (lsame_(pivot, "T")) {
if (lsame_(direct, "F")) {
i__1 = *m;
for (j = 2; j <= i__1; ++j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
i__ * a_dim1 + 1];
/* L50: */
}
}
/* L60: */
}
} else if (lsame_(direct, "B")) {
for (j = *m; j >= 2; --j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
i__ * a_dim1 + 1];
/* L70: */
}
}
/* L80: */
}
}
} else if (lsame_(pivot, "B")) {
if (lsame_(direct, "F")) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
a_dim1] - stemp * temp;
/* L90: */
}
}
/* L100: */
}
} else if (lsame_(direct, "B")) {
for (j = *m - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
a_dim1] - stemp * temp;
/* L110: */
}
}
/* L120: */
}
}
}
} else if (lsame_(side, "R")) {
/* Form A * P' */
if (lsame_(pivot, "V")) {
if (lsame_(direct, "F")) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + (j + 1) * a_dim1];
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
i__ + j * a_dim1];
/* L130: */
}
}
/* L140: */
}
} else if (lsame_(direct, "B")) {
for (j = *n - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + (j + 1) * a_dim1];
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
i__ + j * a_dim1];
/* L150: */
}
}
/* L160: */
}
}
} else if (lsame_(pivot, "T")) {
if (lsame_(direct, "F")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
a_dim1];
/* L170: */
}
}
/* L180: */
}
} else if (lsame_(direct, "B")) {
for (j = *n; j >= 2; --j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
a_dim1];
/* L190: */
}
}
/* L200: */
}
}
} else if (lsame_(pivot, "B")) {
if (lsame_(direct, "F")) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
a_dim1] - stemp * temp;
/* L210: */
}
}
/* L220: */
}
} else if (lsame_(direct, "B")) {
for (j = *n - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
a_dim1] - stemp * temp;
/* L230: */
}
}
/* L240: */
}
}
}
}
return 0;
/* End of DLASR */
} /* dlasr_ */

Some files were not shown because too many files have changed in this diff Show More