From: Vadim Pisarevsky Date: Mon, 25 Apr 2011 21:50:25 +0000 (+0000) Subject: do not use Lapack anymore X-Git-Tag: accepted/2.0/20130307.220821~3308 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=4aaa2700f6665ff46a78df60a1cc06cd029c8dcb;p=profile%2Fivi%2Fopencv.git do not use Lapack anymore --- diff --git a/3rdparty/CMakeLists.txt b/3rdparty/CMakeLists.txt index f536e21..473e712 100644 --- a/3rdparty/CMakeLists.txt +++ b/3rdparty/CMakeLists.txt @@ -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() diff --git a/3rdparty/include/cblas.h b/3rdparty/include/cblas.h deleted file mode 100644 index d1759b0..0000000 --- a/3rdparty/include/cblas.h +++ /dev/null @@ -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 */ diff --git a/3rdparty/include/clapack.h b/3rdparty/include/clapack.h deleted file mode 100644 index 6d14714..0000000 --- a/3rdparty/include/clapack.h +++ /dev/null @@ -1,3715 +0,0 @@ -/* header file for clapack 3.2.1 */ - -#ifndef __CLAPACK_H -#define __CLAPACK_H - -#include "f2c.h" -#include "cblas.h" - -#ifdef __cplusplus -extern "C" { -#endif - -doublereal dasum_(integer *n, doublereal *dx, integer *incx); - -/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, - integer *incx, doublereal *dy, integer *incy); - -doublereal dcabs1_(doublecomplex *z__); - -/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy); - -doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, - integer *incy); - -/* Subroutine */ int dgbmv_(char *trans, integer *m, integer *n, integer *kl, - integer *ku, doublereal *alpha, doublereal *a, integer *lda, - doublereal *x, integer *incx, doublereal *beta, doublereal *y, - integer *incy); - -/* 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); - -/* 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); - -/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *a, integer *lda); - -doublereal dnrm2_(integer *n, doublereal *x, integer *incx); - -/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy, doublereal *c__, doublereal *s); - -/* Subroutine */ int drotg_(doublereal *da, doublereal *db, doublereal *c__, - doublereal *s); - -/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy, doublereal *dparam); - -/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal * - dx1, doublereal *dy1, doublereal *dparam); - -/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal * - alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, - doublereal *beta, doublereal *y, integer *incy); - -/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, - integer *incx); - -doublereal dsdot_(integer *n, real *sx, integer *incx, real *sy, integer * - incy); - -/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha, - doublereal *ap, doublereal *x, integer *incx, doublereal *beta, - doublereal *y, integer *incy); - -/* Subroutine */ int dspr_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *ap); - -/* Subroutine */ int dspr2_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *ap); - -/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy); - -/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n, - doublereal *alpha, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *beta, doublereal *c__, integer *ldc); - -/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha, - doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal - *beta, doublereal *y, integer *incy); - -/* Subroutine */ int dsyr_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *a, integer *lda); - -/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *a, integer *lda); - -/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k, - doublereal *alpha, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *beta, doublereal *c__, integer *ldc); - -/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k, - doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, - doublereal *c__, integer *ldc); - -/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx); - -/* Subroutine */ int dtbsv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx); - -/* Subroutine */ int dtpmv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *ap, doublereal *x, integer *incx); - -/* Subroutine */ int dtpsv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *ap, doublereal *x, integer *incx); - -/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublereal *alpha, doublereal *a, integer * - lda, doublereal *b, integer *ldb); - -/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *x, integer *incx); - -/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublereal *alpha, doublereal *a, integer * - lda, doublereal *b, integer *ldb); - -/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *x, integer *incx); - -integer idamax_(integer *n, doublereal *dx, integer *incx); - -integer isamax_(integer *n, real *sx, integer *incx); - -doublereal sasum_(integer *n, real *sx, integer *incx); - -/* Subroutine */ int saxpy_(integer *n, real *sa, real *sx, integer *incx, - real *sy, integer *incy); - -/* Subroutine */ int scopy_(integer *n, real *sx, integer *incx, real *sy, - integer *incy); - -doublereal sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy); - -doublereal sdsdot_(integer *n, real *sb, real *sx, integer *incx, real *sy, - integer *incy); - -/* Subroutine */ int sgbmv_(char *trans, integer *m, integer *n, integer *kl, - integer *ku, real *alpha, real *a, integer *lda, real *x, integer * - incx, real *beta, real *y, integer *incy); - -/* Subroutine */ int sgemm_(char *transa, char *transb, integer *m, integer * - n, integer *k, real *alpha, real *a, integer *lda, real *b, integer * - ldb, real *beta, real *c__, integer *ldc); - -/* Subroutine */ int sgemv_(char *trans, integer *m, integer *n, real *alpha, - real *a, integer *lda, real *x, integer *incx, real *beta, real *y, - integer *incy); - -/* Subroutine */ int sger_(integer *m, integer *n, real *alpha, real *x, - integer *incx, real *y, integer *incy, real *a, integer *lda); - -doublereal snrm2_(integer *n, real *x, integer *incx); - -/* Subroutine */ int srot_(integer *n, real *sx, integer *incx, real *sy, - integer *incy, real *c__, real *s); - -/* Subroutine */ int srotg_(real *sa, real *sb, real *c__, real *s); - -/* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy, - integer *incy, real *sparam); - -/* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real - *sparam); - -/* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha, - real *a, integer *lda, real *x, integer *incx, real *beta, real *y, - integer *incy); - -/* Subroutine */ int sscal_(integer *n, real *sa, real *sx, integer *incx); - -/* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap, - real *x, integer *incx, real *beta, real *y, integer *incy); - -/* Subroutine */ int sspr_(char *uplo, integer *n, real *alpha, real *x, - integer *incx, real *ap); - -/* Subroutine */ int sspr2_(char *uplo, integer *n, real *alpha, real *x, - integer *incx, real *y, integer *incy, real *ap); - -/* Subroutine */ int sswap_(integer *n, real *sx, integer *incx, real *sy, - integer *incy); - -/* Subroutine */ int ssymm_(char *side, char *uplo, integer *m, integer *n, - real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta, - real *c__, integer *ldc); - -/* Subroutine */ int ssymv_(char *uplo, integer *n, real *alpha, real *a, - integer *lda, real *x, integer *incx, real *beta, real *y, integer * - incy); - -/* Subroutine */ int ssyr_(char *uplo, integer *n, real *alpha, real *x, - integer *incx, real *a, integer *lda); - -/* Subroutine */ int ssyr2_(char *uplo, integer *n, real *alpha, real *x, - integer *incx, real *y, integer *incy, real *a, integer *lda); - -/* Subroutine */ int ssyr2k_(char *uplo, char *trans, integer *n, integer *k, - real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta, - real *c__, integer *ldc); - -/* Subroutine */ int ssyrk_(char *uplo, char *trans, integer *n, integer *k, - real *alpha, real *a, integer *lda, real *beta, real *c__, integer * - ldc); - -/* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, real *a, integer *lda, real *x, integer *incx); - -/* Subroutine */ int stbsv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, real *a, integer *lda, real *x, integer *incx); - -/* Subroutine */ int stpmv_(char *uplo, char *trans, char *diag, integer *n, - real *ap, real *x, integer *incx); - -/* Subroutine */ int stpsv_(char *uplo, char *trans, char *diag, integer *n, - real *ap, real *x, integer *incx); - -/* Subroutine */ int strmm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, real *alpha, real *a, integer *lda, real *b, - integer *ldb); - -/* Subroutine */ int strmv_(char *uplo, char *trans, char *diag, integer *n, - real *a, integer *lda, real *x, integer *incx); - -/* Subroutine */ int strsm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, real *alpha, real *a, integer *lda, real *b, - integer *ldb); - -/* Subroutine */ int strsv_(char *uplo, char *trans, char *diag, integer *n, - real *a, integer *lda, real *x, integer *incx); - -/* Subroutine */ int xerbla_(char *srname, integer *info); - -/* Subroutine */ int xerbla_array__(char *srname_array__, integer * - srname_len__, integer *info, ftnlen srname_array_len); - -/* 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); - -/* 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); - -/* Subroutine */ int ddisna_(char *job, integer *m, integer *n, doublereal * - d__, doublereal *sep, integer *info); - -/* Subroutine */ int dgbbrd_(char *vect, integer *m, integer *n, integer *ncc, - integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal * - d__, doublereal *e, doublereal *q, integer *ldq, doublereal *pt, - integer *ldpt, doublereal *c__, integer *ldc, doublereal *work, - integer *info); - -/* Subroutine */ int dgbcon_(char *norm, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, integer *ipiv, doublereal *anorm, - doublereal *rcond, doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dgbequ_(integer *m, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__, - doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer * - info); - -/* Subroutine */ int dgbequb_(integer *m, integer *n, integer *kl, integer * - ku, doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__, - doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer * - info); - -/* Subroutine */ int dgbrfs_(char *trans, integer *n, integer *kl, integer * - ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, - integer *ldafb, integer *ipiv, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dgbrfsx_(char *trans, char *equed, integer *n, integer * - kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, - doublereal *afb, integer *ldafb, integer *ipiv, doublereal *r__, - doublereal *c__, doublereal *b, integer *ldb, doublereal *x, integer * - ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds__, - doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer * - nparams, doublereal *params, doublereal *work, integer *iwork, - integer *info); - -/* Subroutine */ int dgbsv_(integer *n, integer *kl, integer *ku, integer * - nrhs, doublereal *ab, integer *ldab, integer *ipiv, doublereal *b, - integer *ldb, integer *info); - -/* Subroutine */ int dgbsvx_(char *fact, char *trans, integer *n, integer *kl, - integer *ku, integer *nrhs, doublereal *ab, integer *ldab, - doublereal *afb, integer *ldafb, integer *ipiv, char *equed, - doublereal *r__, doublereal *c__, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, - doublereal *berr, doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dgbsvxx_(char *fact, char *trans, integer *n, integer * - kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, - doublereal *afb, integer *ldafb, integer *ipiv, char *equed, - doublereal *r__, doublereal *c__, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, - doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__, - doublereal *err_bnds_comp__, integer *nparams, doublereal *params, - doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, integer *ipiv, integer *info); - -/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, integer *ipiv, integer *info); - -/* Subroutine */ int dgbtrs_(char *trans, integer *n, integer *kl, integer * - ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv, - doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dgebak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, doublereal *scale, integer *m, doublereal *v, integer * - ldv, integer *info); - -/* Subroutine */ int dgebal_(char *job, integer *n, doublereal *a, integer * - lda, integer *ilo, integer *ihi, doublereal *scale, integer *info); - -/* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * - taup, doublereal *work, integer *info); - -/* 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); - -/* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer * - lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer * - iwork, integer *info); - -/* Subroutine */ int dgeequ_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal - *colcnd, doublereal *amax, integer *info); - -/* Subroutine */ int dgeequb_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal - *colcnd, doublereal *amax, integer *info); - -/* Subroutine */ int dgees_(char *jobvs, char *sort, L_fp select, integer *n, - doublereal *a, integer *lda, integer *sdim, doublereal *wr, - doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work, - integer *lwork, logical *bwork, integer *info); - -/* Subroutine */ int dgeesx_(char *jobvs, char *sort, L_fp select, char * - sense, integer *n, doublereal *a, integer *lda, integer *sdim, - doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, - doublereal *rconde, doublereal *rcondv, doublereal *work, integer * - lwork, integer *iwork, integer *liwork, logical *bwork, integer *info); - -/* Subroutine */ int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal * - a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl, - integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work, - integer *lwork, integer *info); - -/* Subroutine */ int dgeevx_(char *balanc, char *jobvl, char *jobvr, char * - sense, integer *n, doublereal *a, integer *lda, doublereal *wr, - doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, - integer *ldvr, integer *ilo, integer *ihi, doublereal *scale, - doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal - *work, integer *lwork, integer *iwork, integer *info); - -/* Subroutine */ int dgegs_(char *jobvsl, char *jobvsr, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * - alphar, doublereal *alphai, doublereal *beta, doublereal *vsl, - integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work, - integer *lwork, integer *info); - -/* Subroutine */ int dgegv_(char *jobvl, char *jobvr, integer *n, doublereal * - a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, - doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, - doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dgehd2_(integer *n, integer *ilo, integer *ihi, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *info); - -/* Subroutine */ int dgehrd_(integer *n, integer *ilo, integer *ihi, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *lwork, integer *info); - -/* Subroutine */ int dgejsv_(char *joba, char *jobu, char *jobv, char *jobr, - char *jobt, char *jobp, integer *m, integer *n, doublereal *a, - integer *lda, doublereal *sva, doublereal *u, integer *ldu, - doublereal *v, integer *ldv, doublereal *work, integer *lwork, - integer *iwork, integer *info); - -/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); - -/* 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); - -/* 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); - -/* Subroutine */ int dgelss_(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 *info); - -/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - jpvt, doublereal *rcond, integer *rank, doublereal *work, integer * - info); - -/* Subroutine */ int dgelsy_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - jpvt, doublereal *rcond, integer *rank, doublereal *work, integer * - lwork, integer *info); - -/* Subroutine */ int dgeql2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dgeqlf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dgeqp3_(integer *m, integer *n, doublereal *a, integer * - lda, integer *jpvt, doublereal *tau, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer * - lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dgerfs_(char *trans, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer * - ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, - doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, - integer *info); - -/* Subroutine */ int dgerfsx_(char *trans, char *equed, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - integer *ipiv, doublereal *r__, doublereal *c__, doublereal *b, - integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, - doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__, - doublereal *err_bnds_comp__, integer *nparams, doublereal *params, - doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dgerq2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dgerqf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dgesc2_(integer *n, doublereal *a, integer *lda, - doublereal *rhs, integer *ipiv, integer *jpiv, doublereal *scale); - -/* Subroutine */ int dgesdd_(char *jobz, integer *m, integer *n, doublereal * - a, integer *lda, doublereal *s, doublereal *u, integer *ldu, - doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, - integer *iwork, integer *info); - -/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer - *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n, - doublereal *a, integer *lda, doublereal *s, doublereal *u, integer * - ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dgesvj_(char *joba, char *jobu, char *jobv, integer *m, - integer *n, doublereal *a, integer *lda, doublereal *sva, integer *mv, - doublereal *v, integer *ldv, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dgesvx_(char *fact, char *trans, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - integer *ipiv, char *equed, doublereal *r__, doublereal *c__, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * - rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer * - iwork, integer *info); - -/* Subroutine */ int dgesvxx_(char *fact, char *trans, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - integer *ipiv, char *equed, doublereal *r__, doublereal *c__, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * - rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds__, - doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer * - nparams, doublereal *params, doublereal *work, integer *iwork, - integer *info); - -/* Subroutine */ int dgetc2_(integer *n, doublereal *a, integer *lda, integer - *ipiv, integer *jpiv, integer *info); - -/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info); - -/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info); - -/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer - *ipiv, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs, - doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * - ldb, integer *info); - -/* Subroutine */ int dggbak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, doublereal *lscale, doublereal *rscale, integer *m, - doublereal *v, integer *ldv, integer *info); - -/* Subroutine */ int dggbal_(char *job, integer *n, doublereal *a, integer * - lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi, - doublereal *lscale, doublereal *rscale, doublereal *work, integer * - info); - -/* Subroutine */ int dgges_(char *jobvsl, char *jobvsr, char *sort, L_fp - selctg, integer *n, doublereal *a, integer *lda, doublereal *b, - integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai, - doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr, - integer *ldvsr, doublereal *work, integer *lwork, logical *bwork, - integer *info); - -/* Subroutine */ int dggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp - selctg, char *sense, integer *n, doublereal *a, integer *lda, - doublereal *b, integer *ldb, integer *sdim, doublereal *alphar, - doublereal *alphai, doublereal *beta, doublereal *vsl, integer *ldvsl, - doublereal *vsr, integer *ldvsr, doublereal *rconde, doublereal * - rcondv, doublereal *work, integer *lwork, integer *iwork, integer * - liwork, logical *bwork, integer *info); - -/* Subroutine */ int dggev_(char *jobvl, char *jobvr, integer *n, doublereal * - a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, - doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, - doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char * - sense, integer *n, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *alphar, doublereal *alphai, doublereal * - beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, - integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, - doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal * - rcondv, doublereal *work, integer *lwork, integer *iwork, logical * - bwork, integer *info); - -/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, doublereal * - a, integer *lda, doublereal *b, integer *ldb, doublereal *d__, - doublereal *x, doublereal *y, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dgghrd_(char *compq, char *compz, integer *n, integer * - ilo, integer *ihi, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *q, integer *ldq, doublereal *z__, integer * - ldz, integer *info); - -/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, doublereal * - a, integer *lda, doublereal *b, integer *ldb, doublereal *c__, - doublereal *d__, doublereal *x, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dggqrf_(integer *n, integer *m, integer *p, doublereal * - a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, - doublereal *taub, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dggrqf_(integer *m, integer *p, integer *n, doublereal * - a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, - doublereal *taub, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dggsvd_(char *jobu, char *jobv, char *jobq, integer *m, - integer *n, integer *p, integer *k, integer *l, doublereal *a, - integer *lda, doublereal *b, integer *ldb, doublereal *alpha, - doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer - *ldv, doublereal *q, integer *ldq, doublereal *work, integer *iwork, - integer *info); - -/* Subroutine */ int dggsvp_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer - *l, doublereal *u, integer *ldu, doublereal *v, integer *ldv, - doublereal *q, integer *ldq, integer *iwork, doublereal *tau, - doublereal *work, integer *info); - -/* Subroutine */ int dgsvj0_(char *jobv, integer *m, integer *n, doublereal * - a, integer *lda, doublereal *d__, doublereal *sva, integer *mv, - doublereal *v, integer *ldv, doublereal *eps, doublereal *sfmin, - doublereal *tol, integer *nsweep, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dgsvj1_(char *jobv, integer *m, integer *n, integer *n1, - doublereal *a, integer *lda, doublereal *d__, doublereal *sva, - integer *mv, doublereal *v, integer *ldv, doublereal *eps, doublereal - *sfmin, doublereal *tol, integer *nsweep, doublereal *work, integer * - lwork, integer *info); - -/* Subroutine */ int dgtcon_(char *norm, integer *n, doublereal *dl, - doublereal *d__, doublereal *du, doublereal *du2, integer *ipiv, - doublereal *anorm, doublereal *rcond, doublereal *work, integer * - iwork, integer *info); - -/* Subroutine */ int dgtrfs_(char *trans, integer *n, integer *nrhs, - doublereal *dl, doublereal *d__, doublereal *du, doublereal *dlf, - doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * - ferr, doublereal *berr, doublereal *work, integer *iwork, integer * - info); - -/* Subroutine */ int dgtsv_(integer *n, integer *nrhs, doublereal *dl, - doublereal *d__, doublereal *du, doublereal *b, integer *ldb, integer - *info); - -/* Subroutine */ int dgtsvx_(char *fact, char *trans, integer *n, integer * - nrhs, doublereal *dl, doublereal *d__, doublereal *du, doublereal * - dlf, doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * - rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer * - iwork, integer *info); - -/* Subroutine */ int dgttrf_(integer *n, doublereal *dl, doublereal *d__, - doublereal *du, doublereal *du2, integer *ipiv, integer *info); - -/* Subroutine */ int dgttrs_(char *trans, integer *n, integer *nrhs, - doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2, - integer *ipiv, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dgtts2_(integer *itrans, integer *n, integer *nrhs, - doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2, - integer *ipiv, doublereal *b, integer *ldb); - -/* Subroutine */ int dhgeqz_(char *job, char *compq, char *compz, integer *n, - integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal - *t, integer *ldt, doublereal *alphar, doublereal *alphai, doublereal * - beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz, - doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dhsein_(char *side, char *eigsrc, char *initv, logical * - select, integer *n, doublereal *h__, integer *ldh, doublereal *wr, - doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, - integer *ldvr, integer *mm, integer *m, doublereal *work, integer * - ifaill, integer *ifailr, integer *info); - -/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo, - integer *ihi, doublereal *h__, integer *ldh, doublereal *wr, - doublereal *wi, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *info); - -logical disnan_(doublereal *din); - -/* Subroutine */ int dla_gbamv__(integer *trans, integer *m, integer *n, - integer *kl, integer *ku, doublereal *alpha, doublereal *ab, integer * - ldab, doublereal *x, integer *incx, doublereal *beta, doublereal *y, - integer *incy); - -doublereal dla_gbrcond__(char *trans, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, - integer *ipiv, integer *cmode, doublereal *c__, integer *info, - doublereal *work, integer *iwork, ftnlen trans_len); - -/* Subroutine */ int dla_gbrfsx_extended__(integer *prec_type__, integer * - trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs, - doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, - integer *ipiv, logical *colequ, doublereal *c__, doublereal *b, - integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out__, - integer *n_norms__, doublereal *errs_n__, doublereal *errs_c__, - doublereal *res, doublereal *ayb, doublereal *dy, doublereal * - y_tail__, doublereal *rcond, integer *ithresh, doublereal *rthresh, - doublereal *dz_ub__, logical *ignore_cwise__, integer *info); - -doublereal dla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer * - ncols, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb); - -/* Subroutine */ int dla_geamv__(integer *trans, integer *m, integer *n, - doublereal *alpha, doublereal *a, integer *lda, doublereal *x, - integer *incx, doublereal *beta, doublereal *y, integer *incy); - -doublereal dla_gercond__(char *trans, integer *n, doublereal *a, integer *lda, - doublereal *af, integer *ldaf, integer *ipiv, integer *cmode, - doublereal *c__, integer *info, doublereal *work, integer *iwork, - ftnlen trans_len); - -/* Subroutine */ int dla_gerfsx_extended__(integer *prec_type__, integer * - trans_type__, integer *n, integer *nrhs, doublereal *a, integer *lda, - doublereal *af, integer *ldaf, integer *ipiv, logical *colequ, - doublereal *c__, doublereal *b, integer *ldb, doublereal *y, integer * - ldy, doublereal *berr_out__, integer *n_norms__, doublereal *errs_n__, - doublereal *errs_c__, doublereal *res, doublereal *ayb, doublereal * - dy, doublereal *y_tail__, doublereal *rcond, integer *ithresh, - doublereal *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, - integer *info); - -/* Subroutine */ int dla_lin_berr__(integer *n, integer *nz, integer *nrhs, - doublereal *res, doublereal *ayb, doublereal *berr); - -doublereal dla_porcond__(char *uplo, integer *n, doublereal *a, integer *lda, - doublereal *af, integer *ldaf, integer *cmode, doublereal *c__, - integer *info, doublereal *work, integer *iwork, ftnlen uplo_len); - -/* Subroutine */ int dla_porfsx_extended__(integer *prec_type__, char *uplo, - integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal * - af, integer *ldaf, logical *colequ, doublereal *c__, doublereal *b, - integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out__, - integer *n_norms__, doublereal *errs_n__, doublereal *errs_c__, - doublereal *res, doublereal *ayb, doublereal *dy, doublereal * - y_tail__, doublereal *rcond, integer *ithresh, doublereal *rthresh, - doublereal *dz_ub__, logical *ignore_cwise__, integer *info, ftnlen - uplo_len); - -doublereal dla_porpvgrw__(char *uplo, integer *ncols, doublereal *a, integer * - lda, doublereal *af, integer *ldaf, doublereal *work, ftnlen uplo_len); - -doublereal dla_rpvgrw__(integer *n, integer *ncols, doublereal *a, integer * - lda, doublereal *af, integer *ldaf); - -/* Subroutine */ int dla_syamv__(integer *uplo, integer *n, doublereal *alpha, - doublereal *a, integer *lda, doublereal *x, integer *incx, - doublereal *beta, doublereal *y, integer *incy); - -doublereal dla_syrcond__(char *uplo, integer *n, doublereal *a, integer *lda, - doublereal *af, integer *ldaf, integer *ipiv, integer *cmode, - doublereal *c__, integer *info, doublereal *work, integer *iwork, - ftnlen uplo_len); - -/* Subroutine */ int dla_syrfsx_extended__(integer *prec_type__, char *uplo, - integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal * - af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c__, - doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal * - berr_out__, integer *n_norms__, doublereal *errs_n__, doublereal * - errs_c__, doublereal *res, doublereal *ayb, doublereal *dy, - doublereal *y_tail__, doublereal *rcond, integer *ithresh, doublereal - *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, integer *info, - ftnlen uplo_len); - -doublereal dla_syrpvgrw__(char *uplo, integer *n, integer *info, doublereal * - a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, - doublereal *work, ftnlen uplo_len); - -/* Subroutine */ int dla_wwaddw__(integer *n, doublereal *x, doublereal *y, - doublereal *w); - -/* Subroutine */ int dlabad_(doublereal *small, doublereal *large); - -/* 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); - -/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x, - integer *isgn, doublereal *est, integer *kase, integer *isave); - -/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x, - integer *isgn, doublereal *est, integer *kase); - -/* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal * - a, integer *lda, doublereal *b, integer *ldb); - -/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *d__, doublereal *p, doublereal *q); - -/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *rt1, doublereal *rt2); - -/* 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); - -/* 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); - -/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q, - integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, - doublereal *work, integer *iwork, integer *info); - -/* 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); - -/* 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); - -/* Subroutine */ int dlaed4_(integer *n, integer *i__, doublereal *d__, - doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam, - integer *info); - -/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__, - doublereal *delta, doublereal *rho, doublereal *dlam); - -/* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal * - rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal * - tau, integer *info); - -/* 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); - -/* 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); - -/* 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); - -/* 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); - -/* Subroutine */ int dlaein_(logical *rightv, logical *noinit, integer *n, - doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi, - doublereal *vr, doublereal *vi, doublereal *b, integer *ldb, - doublereal *work, doublereal *eps3, doublereal *smlnum, doublereal * - bignum, integer *info); - -/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1); - -/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t, - integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1, - integer *n2, doublereal *work, integer *info); - -/* Subroutine */ int dlag2_(doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *safmin, doublereal *scale1, doublereal * - scale2, doublereal *wr1, doublereal *wr2, doublereal *wi); - -/* Subroutine */ int dlag2s_(integer *m, integer *n, doublereal *a, integer * - lda, real *sa, integer *ldsa, integer *info); - -/* Subroutine */ int dlags2_(logical *upper, doublereal *a1, doublereal *a2, - doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3, - doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv, - doublereal *csq, doublereal *snq); - -/* Subroutine */ int dlagtf_(integer *n, doublereal *a, doublereal *lambda, - doublereal *b, doublereal *c__, doublereal *tol, doublereal *d__, - integer *in, integer *info); - -/* Subroutine */ int dlagtm_(char *trans, integer *n, integer *nrhs, - doublereal *alpha, doublereal *dl, doublereal *d__, doublereal *du, - doublereal *x, integer *ldx, doublereal *beta, doublereal *b, integer - *ldb); - -/* Subroutine */ int dlagts_(integer *job, integer *n, doublereal *a, - doublereal *b, doublereal *c__, doublereal *d__, integer *in, - doublereal *y, doublereal *tol, integer *info); - -/* Subroutine */ int dlagv2_(doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *alphar, doublereal *alphai, doublereal * - beta, doublereal *csl, doublereal *snl, doublereal *csr, doublereal * - snr); - -/* Subroutine */ int dlahqr_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal - *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__, - integer *ldz, integer *info); - -/* Subroutine */ int dlahr2_(integer *n, integer *k, integer *nb, doublereal * - a, integer *lda, doublereal *tau, doublereal *t, integer *ldt, - doublereal *y, integer *ldy); - -/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, doublereal * - a, integer *lda, doublereal *tau, doublereal *t, integer *ldt, - doublereal *y, integer *ldy); - -/* Subroutine */ int dlaic1_(integer *job, integer *j, doublereal *x, - doublereal *sest, doublereal *w, doublereal *gamma, doublereal * - sestpr, doublereal *s, doublereal *c__); - -logical dlaisnan_(doublereal *din1, doublereal *din2); - -/* Subroutine */ int dlaln2_(logical *ltrans, integer *na, integer *nw, - doublereal *smin, doublereal *ca, doublereal *a, integer *lda, - doublereal *d1, doublereal *d2, doublereal *b, integer *ldb, - doublereal *wr, doublereal *wi, doublereal *x, integer *ldx, - doublereal *scale, doublereal *xnorm, integer *info); - -/* 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); - -/* 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); - -/* 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); - -/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer - *dtrd1, integer *dtrd2, integer *index); - -integer dlaneg_(integer *n, doublereal *d__, doublereal *lld, doublereal * - sigma, doublereal *pivmin, integer *r__); - -doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, doublereal *work); - -doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer - *lda, doublereal *work); - -doublereal dlangt_(char *norm, integer *n, doublereal *dl, doublereal *d__, - doublereal *du); - -doublereal dlanhs_(char *norm, integer *n, doublereal *a, integer *lda, - doublereal *work); - -doublereal dlansb_(char *norm, char *uplo, integer *n, integer *k, doublereal - *ab, integer *ldab, doublereal *work); - -doublereal dlansf_(char *norm, char *transr, char *uplo, integer *n, - doublereal *a, doublereal *work); - -doublereal dlansp_(char *norm, char *uplo, integer *n, doublereal *ap, - doublereal *work); - -doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e); - -doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer - *lda, doublereal *work); - -doublereal dlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, - doublereal *ab, integer *ldab, doublereal *work); - -doublereal dlantp_(char *norm, char *uplo, char *diag, integer *n, doublereal - *ap, doublereal *work); - -doublereal dlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, - doublereal *a, integer *lda, doublereal *work); - -/* Subroutine */ int dlanv2_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *d__, doublereal *rt1r, doublereal *rt1i, doublereal *rt2r, - doublereal *rt2i, doublereal *cs, doublereal *sn); - -/* Subroutine */ int dlapll_(integer *n, doublereal *x, integer *incx, - doublereal *y, integer *incy, doublereal *ssmin); - -/* Subroutine */ int dlapmt_(logical *forwrd, integer *m, integer *n, - doublereal *x, integer *ldx, integer *k); - -doublereal dlapy2_(doublereal *x, doublereal *y); - -doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__); - -/* Subroutine */ int dlaqgb_(integer *m, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__, - doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed); - -/* Subroutine */ int dlaqge_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal - *colcnd, doublereal *amax, char *equed); - -/* Subroutine */ int dlaqp2_(integer *m, integer *n, integer *offset, - doublereal *a, integer *lda, integer *jpvt, doublereal *tau, - doublereal *vn1, doublereal *vn2, doublereal *work); - -/* Subroutine */ int dlaqps_(integer *m, integer *n, integer *offset, integer - *nb, integer *kb, doublereal *a, integer *lda, integer *jpvt, - doublereal *tau, doublereal *vn1, doublereal *vn2, doublereal *auxv, - doublereal *f, integer *ldf); - -/* Subroutine */ int dlaqr0_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal - *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__, - integer *ldz, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dlaqr1_(integer *n, doublereal *h__, integer *ldh, - doublereal *sr1, doublereal *si1, doublereal *sr2, doublereal *si2, - doublereal *v); - -/* Subroutine */ int dlaqr2_(logical *wantt, logical *wantz, integer *n, - integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer * - ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz, - integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal * - v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer * - nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork); - -/* Subroutine */ int dlaqr3_(logical *wantt, logical *wantz, integer *n, - integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer * - ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz, - integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal * - v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer * - nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork); - -/* Subroutine */ int dlaqr4_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal - *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__, - integer *ldz, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dlaqr5_(logical *wantt, logical *wantz, integer *kacc22, - integer *n, integer *ktop, integer *kbot, integer *nshfts, doublereal - *sr, doublereal *si, doublereal *h__, integer *ldh, integer *iloz, - integer *ihiz, doublereal *z__, integer *ldz, doublereal *v, integer * - ldv, doublereal *u, integer *ldu, integer *nv, doublereal *wv, - integer *ldwv, integer *nh, doublereal *wh, integer *ldwh); - -/* Subroutine */ int dlaqsb_(char *uplo, integer *n, integer *kd, doublereal * - ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax, - char *equed); - -/* Subroutine */ int dlaqsp_(char *uplo, integer *n, doublereal *ap, - doublereal *s, doublereal *scond, doublereal *amax, char *equed); - -/* Subroutine */ int dlaqsy_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *s, doublereal *scond, doublereal *amax, char *equed); - -/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n, - doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal - *scale, doublereal *x, doublereal *work, integer *info); - -/* 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); - -/* Subroutine */ int dlar2v_(integer *n, doublereal *x, doublereal *y, - doublereal *z__, integer *incx, doublereal *c__, doublereal *s, - integer *incc); - -/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v, - integer *incv, doublereal *tau, doublereal *c__, integer *ldc, - doublereal *work); - -/* 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); - -/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, - integer *incx, doublereal *tau); - -/* Subroutine */ int dlarfp_(integer *n, doublereal *alpha, doublereal *x, - integer *incx, doublereal *tau); - -/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer * - k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, - integer *ldt); - -/* Subroutine */ int dlarfx_(char *side, integer *m, integer *n, doublereal * - v, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work); - -/* Subroutine */ int dlargv_(integer *n, doublereal *x, integer *incx, - doublereal *y, integer *incy, doublereal *c__, integer *incc); - -/* Subroutine */ int dlarnv_(integer *idist, integer *iseed, integer *n, - doublereal *x); - -/* Subroutine */ int dlarra_(integer *n, doublereal *d__, doublereal *e, - doublereal *e2, doublereal *spltol, doublereal *tnrm, integer *nsplit, - integer *isplit, integer *info); - -/* 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); - -/* 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); - -/* 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); - -/* 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); - -/* 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); - -/* 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); - -/* 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); - -/* Subroutine */ int dlarrr_(integer *n, doublereal *d__, doublereal *e, - integer *info); - -/* 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); - -/* Subroutine */ int dlarscl2_(integer *m, integer *n, doublereal *d__, - doublereal *x, integer *ldx); - -/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs, - doublereal *sn, doublereal *r__); - -/* Subroutine */ int dlartv_(integer *n, doublereal *x, integer *incx, - doublereal *y, integer *incy, doublereal *c__, doublereal *s, integer - *incc); - -/* Subroutine */ int dlaruv_(integer *iseed, integer *n, doublereal *x); - -/* Subroutine */ int dlarz_(char *side, integer *m, integer *n, integer *l, - doublereal *v, integer *incv, doublereal *tau, doublereal *c__, - integer *ldc, doublereal *work); - -/* Subroutine */ int dlarzb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, integer *l, doublereal *v, - integer *ldv, doublereal *t, integer *ldt, doublereal *c__, integer * - ldc, doublereal *work, integer *ldwork); - -/* Subroutine */ int dlarzt_(char *direct, char *storev, integer *n, integer * - k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, - integer *ldt); - -/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax); - -/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku, - doublereal *cfrom, doublereal *cto, integer *m, integer *n, - doublereal *a, integer *lda, integer *info); - -/* Subroutine */ int dlascl2_(integer *m, integer *n, doublereal *d__, - doublereal *x, integer *ldx); - -/* 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); - -/* 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); - -/* 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); - -/* 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); - -/* Subroutine */ int dlasd4_(integer *n, integer *i__, doublereal *d__, - doublereal *z__, doublereal *delta, doublereal *rho, doublereal * - sigma, doublereal *work, integer *info); - -/* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__, - doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal * - work); - -/* 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); - -/* 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); - -/* 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); - -/* 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); - -/* 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); - -/* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer * - inode, integer *ndiml, integer *ndimr, integer *msub); - -/* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal * - alpha, doublereal *beta, doublereal *a, integer *lda); - -/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e, - doublereal *work, integer *info); - -/* Subroutine */ int dlasq2_(integer *n, doublereal *z__, integer *info); - -/* 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); - -/* 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); - -/* 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); - -/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, - doublereal *dn, doublereal *dnm1, doublereal *dnm2); - -/* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m, - integer *n, doublereal *c__, doublereal *s, doublereal *a, integer * - lda); - -/* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer * - info); - -/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx, - doublereal *scale, doublereal *sumsq); - -/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal * - csr, doublereal *snl, doublereal *csl); - -/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer - *k1, integer *k2, integer *ipiv, integer *incx); - -/* Subroutine */ int dlasy2_(logical *ltranl, logical *ltranr, integer *isgn, - integer *n1, integer *n2, doublereal *tl, integer *ldtl, doublereal * - tr, integer *ldtr, doublereal *b, integer *ldb, doublereal *scale, - doublereal *x, integer *ldx, doublereal *xnorm, integer *info); - -/* Subroutine */ int dlasyf_(char *uplo, integer *n, integer *nb, integer *kb, - doublereal *a, integer *lda, integer *ipiv, doublereal *w, integer * - ldw, integer *info); - -/* Subroutine */ int dlat2s_(char *uplo, integer *n, doublereal *a, integer * - lda, real *sa, integer *ldsa, integer *info); - -/* Subroutine */ int dlatbs_(char *uplo, char *trans, char *diag, char * - normin, integer *n, integer *kd, doublereal *ab, integer *ldab, - doublereal *x, doublereal *scale, doublereal *cnorm, integer *info); - -/* Subroutine */ int dlatdf_(integer *ijob, integer *n, doublereal *z__, - integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal, - integer *ipiv, integer *jpiv); - -/* Subroutine */ int dlatps_(char *uplo, char *trans, char *diag, char * - normin, integer *n, doublereal *ap, doublereal *x, doublereal *scale, - doublereal *cnorm, integer *info); - -/* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal * - a, integer *lda, doublereal *e, doublereal *tau, doublereal *w, - integer *ldw); - -/* Subroutine */ int dlatrs_(char *uplo, char *trans, char *diag, char * - normin, integer *n, doublereal *a, integer *lda, doublereal *x, - doublereal *scale, doublereal *cnorm, integer *info); - -/* Subroutine */ int dlatrz_(integer *m, integer *n, integer *l, doublereal * - a, integer *lda, doublereal *tau, doublereal *work); - -/* Subroutine */ int dlatzm_(char *side, integer *m, integer *n, doublereal * - v, integer *incv, doublereal *tau, doublereal *c1, doublereal *c2, - integer *ldc, doublereal *work); - -/* Subroutine */ int dlauu2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info); - -/* Subroutine */ int dlauum_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info); - -/* Subroutine */ int dopgtr_(char *uplo, integer *n, doublereal *ap, - doublereal *tau, doublereal *q, integer *ldq, doublereal *work, - integer *info); - -/* Subroutine */ int dopmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublereal *ap, doublereal *tau, doublereal *c__, integer - *ldc, doublereal *work, integer *info); - -/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *lwork, integer *info); - -/* Subroutine */ int dorghr_(integer *n, integer *ilo, integer *ihi, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *lwork, integer *info); - -/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dorgr2_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info); - -/* Subroutine */ int dorgrq_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dorgtr_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info); - -/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info); - -/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dormhr_(char *side, char *trans, integer *m, integer *n, - integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal * - tau, doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info); - -/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dormr2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info); - -/* Subroutine */ int dormr3_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *info); - -/* Subroutine */ int dormrq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dormrz_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dpbcon_(char *uplo, integer *n, integer *kd, doublereal * - ab, integer *ldab, doublereal *anorm, doublereal *rcond, doublereal * - work, integer *iwork, integer *info); - -/* Subroutine */ int dpbequ_(char *uplo, integer *n, integer *kd, doublereal * - ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax, - integer *info); - -/* Subroutine */ int dpbrfs_(char *uplo, integer *n, integer *kd, integer * - nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * - ferr, doublereal *berr, doublereal *work, integer *iwork, integer * - info); - -/* Subroutine */ int dpbstf_(char *uplo, integer *n, integer *kd, doublereal * - ab, integer *ldab, integer *info); - -/* Subroutine */ int dpbsv_(char *uplo, integer *n, integer *kd, integer * - nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb, - integer *info); - -/* Subroutine */ int dpbsvx_(char *fact, char *uplo, integer *n, integer *kd, - integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, - integer *ldafb, char *equed, doublereal *s, doublereal *b, integer * - ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, - doublereal *berr, doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dpbtf2_(char *uplo, integer *n, integer *kd, doublereal * - ab, integer *ldab, integer *info); - -/* Subroutine */ int dpbtrf_(char *uplo, integer *n, integer *kd, doublereal * - ab, integer *ldab, integer *info); - -/* Subroutine */ int dpbtrs_(char *uplo, integer *n, integer *kd, integer * - nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb, - integer *info); - -/* Subroutine */ int dpftrf_(char *transr, char *uplo, integer *n, doublereal - *a, integer *info); - -/* Subroutine */ int dpftri_(char *transr, char *uplo, integer *n, doublereal - *a, integer *info); - -/* Subroutine */ int dpftrs_(char *transr, char *uplo, integer *n, integer * - nrhs, doublereal *a, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dpocon_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer * - iwork, integer *info); - -/* Subroutine */ int dpoequ_(integer *n, doublereal *a, integer *lda, - doublereal *s, doublereal *scond, doublereal *amax, integer *info); - -/* Subroutine */ int dpoequb_(integer *n, doublereal *a, integer *lda, - doublereal *s, doublereal *scond, doublereal *amax, integer *info); - -/* Subroutine */ int dporfs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *af, integer *ldaf, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * - ferr, doublereal *berr, doublereal *work, integer *iwork, integer * - info); - -/* Subroutine */ int dporfsx_(char *uplo, char *equed, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer * - ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds__, - doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer * - nparams, doublereal *params, doublereal *work, integer *iwork, - integer *info); - -/* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal - *a, integer *lda, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dposvx_(char *fact, char *uplo, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal * - x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal * - berr, doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dposvxx_(char *fact, char *uplo, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal * - x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal * - berr, integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal * - err_bnds_comp__, integer *nparams, doublereal *params, doublereal * - work, integer *iwork, integer *info); - -/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info); - -/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info); - -/* Subroutine */ int dpotri_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info); - -/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - info); - -/* Subroutine */ int dppcon_(char *uplo, integer *n, doublereal *ap, - doublereal *anorm, doublereal *rcond, doublereal *work, integer * - iwork, integer *info); - -/* Subroutine */ int dppequ_(char *uplo, integer *n, doublereal *ap, - doublereal *s, doublereal *scond, doublereal *amax, integer *info); - -/* Subroutine */ int dpprfs_(char *uplo, integer *n, integer *nrhs, - doublereal *ap, doublereal *afp, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dppsv_(char *uplo, integer *n, integer *nrhs, doublereal - *ap, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dppsvx_(char *fact, char *uplo, integer *n, integer * - nrhs, doublereal *ap, doublereal *afp, char *equed, doublereal *s, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * - rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer * - iwork, integer *info); - -/* Subroutine */ int dpptrf_(char *uplo, integer *n, doublereal *ap, integer * - info); - -/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer * - info); - -/* Subroutine */ int dpptrs_(char *uplo, integer *n, integer *nrhs, - doublereal *ap, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dpstf2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *piv, integer *rank, doublereal *tol, doublereal *work, - integer *info); - -/* Subroutine */ int dpstrf_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *piv, integer *rank, doublereal *tol, doublereal *work, - integer *info); - -/* Subroutine */ int dptcon_(integer *n, doublereal *d__, doublereal *e, - doublereal *anorm, doublereal *rcond, doublereal *work, integer *info); - -/* Subroutine */ int dpteqr_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *info); - -/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, doublereal *d__, - doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer - *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *info); - -/* Subroutine */ int dptsv_(integer *n, integer *nrhs, doublereal *d__, - doublereal *e, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dptsvx_(char *fact, integer *n, integer *nrhs, - doublereal *d__, doublereal *e, doublereal *df, doublereal *ef, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * - rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer * - info); - -/* Subroutine */ int dpttrf_(integer *n, doublereal *d__, doublereal *e, - integer *info); - -/* Subroutine */ int dpttrs_(integer *n, integer *nrhs, doublereal *d__, - doublereal *e, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dptts2_(integer *n, integer *nrhs, doublereal *d__, - doublereal *e, doublereal *b, integer *ldb); - -/* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx, - integer *incx); - -/* Subroutine */ int dsbev_(char *jobz, char *uplo, integer *n, integer *kd, - doublereal *ab, integer *ldab, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *info); - -/* Subroutine */ int dsbevd_(char *jobz, char *uplo, integer *n, integer *kd, - doublereal *ab, integer *ldab, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *lwork, integer *iwork, - integer *liwork, integer *info); - -/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n, - integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer * - ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu, - doublereal *abstol, integer *m, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *iwork, integer *ifail, - integer *info); - -/* Subroutine */ int dsbgst_(char *vect, char *uplo, integer *n, integer *ka, - integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer * - ldbb, doublereal *x, integer *ldx, doublereal *work, integer *info); - -/* Subroutine */ int dsbgv_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer * - ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *info); - -/* Subroutine */ int dsbgvd_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer * - ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dsbgvx_(char *jobz, char *range, char *uplo, integer *n, - integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal * - bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl, - doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer - *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *iwork, integer *ifail, integer *info); - -/* Subroutine */ int dsbtrd_(char *vect, char *uplo, integer *n, integer *kd, - doublereal *ab, integer *ldab, doublereal *d__, doublereal *e, - doublereal *q, integer *ldq, doublereal *work, integer *info); - -/* Subroutine */ int dsfrk_(char *transr, char *uplo, char *trans, integer *n, - integer *k, doublereal *alpha, doublereal *a, integer *lda, - doublereal *beta, doublereal *c__); - -/* Subroutine */ int dsgesv_(integer *n, integer *nrhs, doublereal *a, - integer *lda, integer *ipiv, doublereal *b, integer *ldb, doublereal * - x, integer *ldx, doublereal *work, real *swork, integer *iter, - integer *info); - -/* Subroutine */ int dspcon_(char *uplo, integer *n, doublereal *ap, integer * - ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer - *iwork, integer *info); - -/* Subroutine */ int dspev_(char *jobz, char *uplo, integer *n, doublereal * - ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *info); - -/* Subroutine */ int dspevd_(char *jobz, char *uplo, integer *n, doublereal * - ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dspevx_(char *jobz, char *range, char *uplo, integer *n, - doublereal *ap, doublereal *vl, doublereal *vu, integer *il, integer * - iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *iwork, integer *ifail, - integer *info); - -/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n, - doublereal *ap, doublereal *bp, integer *info); - -/* Subroutine */ int dspgv_(integer *itype, char *jobz, char *uplo, integer * - n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *info); - -/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer * - n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *lwork, integer *iwork, - integer *liwork, integer *info); - -/* Subroutine */ int dspgvx_(integer *itype, char *jobz, char *range, char * - uplo, integer *n, doublereal *ap, doublereal *bp, doublereal *vl, - doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer - *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *iwork, integer *ifail, integer *info); - -/* Subroutine */ int dsposv_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * - x, integer *ldx, doublereal *work, real *swork, integer *iter, - integer *info); - -/* Subroutine */ int dsprfs_(char *uplo, integer *n, integer *nrhs, - doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, - integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, - doublereal *berr, doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dspsv_(char *uplo, integer *n, integer *nrhs, doublereal - *ap, integer *ipiv, doublereal *b, integer *ldb, integer *info); - -/* Subroutine */ int dspsvx_(char *fact, char *uplo, integer *n, integer * - nrhs, doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, - integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, - doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, - integer *info); - -/* Subroutine */ int dsptrd_(char *uplo, integer *n, doublereal *ap, - doublereal *d__, doublereal *e, doublereal *tau, integer *info); - -/* Subroutine */ int dsptrf_(char *uplo, integer *n, doublereal *ap, integer * - ipiv, integer *info); - -/* Subroutine */ int dsptri_(char *uplo, integer *n, doublereal *ap, integer * - ipiv, doublereal *work, integer *info); - -/* Subroutine */ int dsptrs_(char *uplo, integer *n, integer *nrhs, - doublereal *ap, integer *ipiv, doublereal *b, integer *ldb, integer * - info); - -/* Subroutine */ int dstebz_(char *range, char *order, integer *n, doublereal - *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, - doublereal *d__, doublereal *e, integer *m, integer *nsplit, - doublereal *w, integer *iblock, integer *isplit, doublereal *work, - integer *iwork, integer *info); - -/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dstegr_(char *jobz, char *range, integer *n, doublereal * - d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, - integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dstein_(integer *n, doublereal *d__, doublereal *e, - integer *m, doublereal *w, integer *iblock, integer *isplit, - doublereal *z__, integer *ldz, doublereal *work, integer *iwork, - integer *ifail, integer *info); - -/* Subroutine */ int dstemr_(char *jobz, char *range, integer *n, doublereal * - d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, - integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz, - integer *nzc, integer *isuppz, logical *tryrac, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *info); - -/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e, - integer *info); - -/* Subroutine */ int dstev_(char *jobz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *info); - -/* Subroutine */ int dstevd_(char *jobz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dstevr_(char *jobz, char *range, integer *n, doublereal * - d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, - integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dstevx_(char *jobz, char *range, integer *n, doublereal * - d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, - integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, doublereal *work, integer *iwork, - integer *ifail, integer *info); - -/* Subroutine */ int dsycon_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal * - work, integer *iwork, integer *info); - -/* Subroutine */ int dsyequb_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *s, doublereal *scond, doublereal *amax, doublereal * - work, integer *info); - -/* Subroutine */ int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a, - integer *lda, doublereal *w, doublereal *work, integer *lwork, - integer *info); - -/* Subroutine */ int dsyevd_(char *jobz, char *uplo, integer *n, doublereal * - a, integer *lda, doublereal *w, doublereal *work, integer *lwork, - integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dsyevr_(char *jobz, char *range, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer * - il, integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int dsyevx_(char *jobz, char *range, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer * - il, integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, doublereal *work, integer *lwork, - integer *iwork, integer *ifail, integer *info); - -/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - info); - -/* Subroutine */ int dsygst_(integer *itype, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - info); - -/* Subroutine */ int dsygv_(integer *itype, char *jobz, char *uplo, integer * - n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *w, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dsygvd_(integer *itype, char *jobz, char *uplo, integer * - n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *w, doublereal *work, integer *lwork, integer *iwork, - integer *liwork, integer *info); - -/* Subroutine */ int dsygvx_(integer *itype, char *jobz, char *range, char * - uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer - *ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu, - doublereal *abstol, integer *m, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *lwork, integer *iwork, - integer *ifail, integer *info); - -/* Subroutine */ int dsyrfs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer * - ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, - doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, - integer *info); - -/* Subroutine */ int dsyrfsx_(char *uplo, char *equed, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - integer *ipiv, doublereal *s, doublereal *b, integer *ldb, doublereal - *x, integer *ldx, doublereal *rcond, doublereal *berr, integer * - n_err_bnds__, doublereal *err_bnds_norm__, doublereal * - err_bnds_comp__, integer *nparams, doublereal *params, doublereal * - work, integer *iwork, integer *info); - -/* Subroutine */ int dsysv_(char *uplo, integer *n, integer *nrhs, doublereal - *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, - doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dsysvx_(char *fact, char *uplo, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer * - ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, - doublereal *work, integer *lwork, integer *iwork, integer *info); - -/* Subroutine */ int dsysvxx_(char *fact, char *uplo, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - integer *ipiv, char *equed, doublereal *s, doublereal *b, integer * - ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal * - rpvgrw, doublereal *berr, integer *n_err_bnds__, doublereal * - err_bnds_norm__, doublereal *err_bnds_comp__, integer *nparams, - doublereal *params, doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info); - -/* Subroutine */ int dsytf2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info); - -/* Subroutine */ int dsytrd_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tau, doublereal * - work, integer *lwork, integer *info); - -/* Subroutine */ int dsytrf_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *ipiv, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *ipiv, doublereal *work, integer *info); - -/* Subroutine */ int dsytrs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * - ldb, integer *info); - -/* Subroutine */ int dtbcon_(char *norm, char *uplo, char *diag, integer *n, - integer *kd, doublereal *ab, integer *ldab, doublereal *rcond, - doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dtbrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal - *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, - doublereal *berr, doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dtbtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal - *b, integer *ldb, integer *info); - -/* Subroutine */ int dtfsm_(char *transr, char *side, char *uplo, char *trans, - char *diag, integer *m, integer *n, doublereal *alpha, doublereal *a, - doublereal *b, integer *ldb); - -/* Subroutine */ int dtftri_(char *transr, char *uplo, char *diag, integer *n, - doublereal *a, integer *info); - -/* Subroutine */ int dtfttp_(char *transr, char *uplo, integer *n, doublereal - *arf, doublereal *ap, integer *info); - -/* Subroutine */ int dtfttr_(char *transr, char *uplo, integer *n, doublereal - *arf, doublereal *a, integer *lda, integer *info); - -/* Subroutine */ int dtgevc_(char *side, char *howmny, logical *select, - integer *n, doublereal *s, integer *lds, doublereal *p, integer *ldp, - doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer - *mm, integer *m, doublereal *work, integer *info); - -/* Subroutine */ int dtgex2_(logical *wantq, logical *wantz, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * - q, integer *ldq, doublereal *z__, integer *ldz, integer *j1, integer * - n1, integer *n2, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dtgexc_(logical *wantq, logical *wantz, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * - q, integer *ldq, doublereal *z__, integer *ldz, integer *ifst, - integer *ilst, doublereal *work, integer *lwork, integer *info); - -/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz, - logical *select, integer *n, doublereal *a, integer *lda, doublereal * - b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal * - beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz, - integer *m, doublereal *pl, doublereal *pr, doublereal *dif, - doublereal *work, integer *lwork, integer *iwork, integer *liwork, - integer *info); - -/* Subroutine */ int dtgsja_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, integer *k, integer *l, doublereal *a, - integer *lda, doublereal *b, integer *ldb, doublereal *tola, - doublereal *tolb, doublereal *alpha, doublereal *beta, doublereal *u, - integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer * - ldq, doublereal *work, integer *ncycle, integer *info); - -/* Subroutine */ int dtgsna_(char *job, char *howmny, logical *select, - integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, - doublereal *s, doublereal *dif, integer *mm, integer *m, doublereal * - work, integer *lwork, integer *iwork, integer *info); - -/* Subroutine */ int dtgsy2_(char *trans, integer *ijob, integer *m, integer * - n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *c__, integer *ldc, doublereal *d__, integer *ldd, - doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal * - scale, doublereal *rdsum, doublereal *rdscal, integer *iwork, integer - *pq, integer *info); - -/* Subroutine */ int dtgsyl_(char *trans, integer *ijob, integer *m, integer * - n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *c__, integer *ldc, doublereal *d__, integer *ldd, - doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal * - scale, doublereal *dif, doublereal *work, integer *lwork, integer * - iwork, integer *info); - -/* Subroutine */ int dtpcon_(char *norm, char *uplo, char *diag, integer *n, - doublereal *ap, doublereal *rcond, doublereal *work, integer *iwork, - integer *info); - -/* Subroutine */ int dtprfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dtptri_(char *uplo, char *diag, integer *n, doublereal * - ap, integer *info); - -/* Subroutine */ int dtptrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer * - info); - -/* Subroutine */ int dtpttf_(char *transr, char *uplo, integer *n, doublereal - *ap, doublereal *arf, integer *info); - -/* Subroutine */ int dtpttr_(char *uplo, integer *n, doublereal *ap, - doublereal *a, integer *lda, integer *info); - -/* Subroutine */ int dtrcon_(char *norm, char *uplo, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *rcond, doublereal *work, - integer *iwork, integer *info); - -/* Subroutine */ int dtrevc_(char *side, char *howmny, logical *select, - integer *n, doublereal *t, integer *ldt, doublereal *vl, integer * - ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m, - doublereal *work, integer *info); - -/* Subroutine */ int dtrexc_(char *compq, integer *n, doublereal *t, integer * - ldt, doublereal *q, integer *ldq, integer *ifst, integer *ilst, - doublereal *work, integer *info); - -/* Subroutine */ int dtrrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer * - ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info); - -/* Subroutine */ int dtrsen_(char *job, char *compq, logical *select, integer - *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq, - doublereal *wr, doublereal *wi, integer *m, doublereal *s, doublereal - *sep, doublereal *work, integer *lwork, integer *iwork, integer * - liwork, integer *info); - -/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select, - integer *n, doublereal *t, integer *ldt, doublereal *vl, integer * - ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep, - integer *mm, integer *m, doublereal *work, integer *ldwork, integer * - iwork, integer *info); - -/* Subroutine */ int dtrsyl_(char *trana, char *tranb, integer *isgn, integer - *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer * - ldb, doublereal *c__, integer *ldc, doublereal *scale, integer *info); - -/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal * - a, integer *lda, integer *info); - -/* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal * - a, integer *lda, integer *info); - -/* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer * - ldb, integer *info); - -/* Subroutine */ int dtrttf_(char *transr, char *uplo, integer *n, doublereal - *a, integer *lda, doublereal *arf, integer *info); - -/* Subroutine */ int dtrttp_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *ap, integer *info); - -/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, integer *info); - -/* Subroutine */ int dtzrzf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); - -doublereal dzsum1_(integer *n, doublecomplex *cx, integer *incx); - -integer icmax1_(integer *n, complex *cx, integer *incx); - -integer ieeeck_(integer *ispec, real *zero, real *one); - -integer ilaclc_(integer *m, integer *n, complex *a, integer *lda); - -integer ilaclr_(integer *m, integer *n, complex *a, integer *lda); - -integer iladiag_(char *diag); - -integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda); - -integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda); - -integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, - integer *n2, integer *n3, integer *n4); - -integer ilaprec_(char *prec); - -integer ilaslc_(integer *m, integer *n, real *a, integer *lda); - -integer ilaslr_(integer *m, integer *n, real *a, integer *lda); - -integer ilatrans_(char *trans); - -integer ilauplo_(char *uplo); - -/* Subroutine */ int ilaver_(integer *vers_major__, integer *vers_minor__, - integer *vers_patch__); - -integer ilazlc_(integer *m, integer *n, doublecomplex *a, integer *lda); - -integer ilazlr_(integer *m, integer *n, doublecomplex *a, integer *lda); - -integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer - *ilo, integer *ihi, integer *lwork); - -integer izmax1_(integer *n, doublecomplex *cx, integer *incx); - -logical lsamen_(integer *n, char *ca, char *cb); - -integer smaxloc_(real *a, integer *dimm); - -/* Subroutine */ int sbdsdc_(char *uplo, char *compq, integer *n, real *d__, - real *e, real *u, integer *ldu, real *vt, integer *ldvt, real *q, - integer *iq, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sbdsqr_(char *uplo, integer *n, integer *ncvt, integer * - nru, integer *ncc, real *d__, real *e, real *vt, integer *ldvt, real * - u, integer *ldu, real *c__, integer *ldc, real *work, integer *info); - -doublereal scsum1_(integer *n, complex *cx, integer *incx); - -/* Subroutine */ int sdisna_(char *job, integer *m, integer *n, real *d__, - real *sep, integer *info); - -/* Subroutine */ int sgbbrd_(char *vect, integer *m, integer *n, integer *ncc, - integer *kl, integer *ku, real *ab, integer *ldab, real *d__, real * - e, real *q, integer *ldq, real *pt, integer *ldpt, real *c__, integer - *ldc, real *work, integer *info); - -/* Subroutine */ int sgbcon_(char *norm, integer *n, integer *kl, integer *ku, - real *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, - real *work, integer *iwork, integer *info); - -/* Subroutine */ int sgbequ_(integer *m, integer *n, integer *kl, integer *ku, - real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real * - colcnd, real *amax, integer *info); - -/* Subroutine */ int sgbequb_(integer *m, integer *n, integer *kl, integer * - ku, real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real - *colcnd, real *amax, integer *info); - -/* Subroutine */ int sgbrfs_(char *trans, integer *n, integer *kl, integer * - ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, - integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real * - ferr, real *berr, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sgbrfsx_(char *trans, char *equed, integer *n, integer * - kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, - integer *ldafb, integer *ipiv, real *r__, real *c__, real *b, integer - *ldb, real *x, integer *ldx, real *rcond, real *berr, integer * - n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer * - nparams, real *params, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sgbsv_(integer *n, integer *kl, integer *ku, integer * - nrhs, real *ab, integer *ldab, integer *ipiv, real *b, integer *ldb, - integer *info); - -/* Subroutine */ int sgbsvx_(char *fact, char *trans, integer *n, integer *kl, - integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, - integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__, - real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, - real *berr, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sgbsvxx_(char *fact, char *trans, integer *n, integer * - kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, - integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__, - real *b, integer *ldb, real *x, integer *ldx, real *rcond, real * - rpvgrw, real *berr, integer *n_err_bnds__, real *err_bnds_norm__, - real *err_bnds_comp__, integer *nparams, real *params, real *work, - integer *iwork, integer *info); - -/* Subroutine */ int sgbtf2_(integer *m, integer *n, integer *kl, integer *ku, - real *ab, integer *ldab, integer *ipiv, integer *info); - -/* Subroutine */ int sgbtrf_(integer *m, integer *n, integer *kl, integer *ku, - real *ab, integer *ldab, integer *ipiv, integer *info); - -/* Subroutine */ int sgbtrs_(char *trans, integer *n, integer *kl, integer * - ku, integer *nrhs, real *ab, integer *ldab, integer *ipiv, real *b, - integer *ldb, integer *info); - -/* Subroutine */ int sgebak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, real *scale, integer *m, real *v, integer *ldv, integer - *info); - -/* Subroutine */ int sgebal_(char *job, integer *n, real *a, integer *lda, - integer *ilo, integer *ihi, real *scale, integer *info); - -/* Subroutine */ int sgebd2_(integer *m, integer *n, real *a, integer *lda, - real *d__, real *e, real *tauq, real *taup, real *work, integer *info); - -/* Subroutine */ int sgebrd_(integer *m, integer *n, real *a, integer *lda, - real *d__, real *e, real *tauq, real *taup, real *work, integer * - lwork, integer *info); - -/* Subroutine */ int sgecon_(char *norm, integer *n, real *a, integer *lda, - real *anorm, real *rcond, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sgeequ_(integer *m, integer *n, real *a, integer *lda, - real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, integer - *info); - -/* Subroutine */ int sgeequb_(integer *m, integer *n, real *a, integer *lda, - real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, integer - *info); - -/* Subroutine */ int sgees_(char *jobvs, char *sort, L_fp select, integer *n, - real *a, integer *lda, integer *sdim, real *wr, real *wi, real *vs, - integer *ldvs, real *work, integer *lwork, logical *bwork, integer * - info); - -/* Subroutine */ int sgeesx_(char *jobvs, char *sort, L_fp select, char * - sense, integer *n, real *a, integer *lda, integer *sdim, real *wr, - real *wi, real *vs, integer *ldvs, real *rconde, real *rcondv, real * - work, integer *lwork, integer *iwork, integer *liwork, logical *bwork, - integer *info); - -/* Subroutine */ int sgeev_(char *jobvl, char *jobvr, integer *n, real *a, - integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr, - integer *ldvr, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char * - sense, integer *n, real *a, integer *lda, real *wr, real *wi, real * - vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer * - ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work, - integer *lwork, integer *iwork, integer *info); - -/* Subroutine */ int sgegs_(char *jobvsl, char *jobvsr, integer *n, real *a, - integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real - *beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real * - work, integer *lwork, integer *info); - -/* Subroutine */ int sgegv_(char *jobvl, char *jobvr, integer *n, real *a, - integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real - *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int sgehd2_(integer *n, integer *ilo, integer *ihi, real *a, - integer *lda, real *tau, real *work, integer *info); - -/* Subroutine */ int sgehrd_(integer *n, integer *ilo, integer *ihi, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgejsv_(char *joba, char *jobu, char *jobv, char *jobr, - char *jobt, char *jobp, integer *m, integer *n, real *a, integer *lda, - real *sva, real *u, integer *ldu, real *v, integer *ldv, real *work, - integer *lwork, integer *iwork, integer *info); - -/* Subroutine */ int sgelq2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info); - -/* Subroutine */ int sgelqf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgels_(char *trans, integer *m, integer *n, integer * - nrhs, real *a, integer *lda, real *b, integer *ldb, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int sgelsd_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, real *s, real *rcond, integer * - rank, real *work, integer *lwork, integer *iwork, integer *info); - -/* Subroutine */ int sgelss_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, real *s, real *rcond, integer * - rank, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgelsx_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond, - integer *rank, real *work, integer *info); - -/* Subroutine */ int sgelsy_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond, - integer *rank, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgeql2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info); - -/* Subroutine */ int sgeqlf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgeqp3_(integer *m, integer *n, real *a, integer *lda, - integer *jpvt, real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgeqpf_(integer *m, integer *n, real *a, integer *lda, - integer *jpvt, real *tau, real *work, integer *info); - -/* Subroutine */ int sgeqr2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info); - -/* Subroutine */ int sgeqrf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgerfs_(char *trans, integer *n, integer *nrhs, real *a, - integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, - integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real * - work, integer *iwork, integer *info); - -/* Subroutine */ int sgerfsx_(char *trans, char *equed, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, - real *r__, real *c__, real *b, integer *ldb, real *x, integer *ldx, - real *rcond, real *berr, integer *n_err_bnds__, real *err_bnds_norm__, - real *err_bnds_comp__, integer *nparams, real *params, real *work, - integer *iwork, integer *info); - -/* Subroutine */ int sgerq2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info); - -/* Subroutine */ int sgerqf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgesc2_(integer *n, real *a, integer *lda, real *rhs, - integer *ipiv, integer *jpiv, real *scale); - -/* Subroutine */ int sgesdd_(char *jobz, integer *m, integer *n, real *a, - integer *lda, real *s, real *u, integer *ldu, real *vt, integer *ldvt, - real *work, integer *lwork, integer *iwork, integer *info); - -/* Subroutine */ int sgesv_(integer *n, integer *nrhs, real *a, integer *lda, - integer *ipiv, real *b, integer *ldb, integer *info); - -/* Subroutine */ int sgesvd_(char *jobu, char *jobvt, integer *m, integer *n, - real *a, integer *lda, real *s, real *u, integer *ldu, real *vt, - integer *ldvt, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgesvj_(char *joba, char *jobu, char *jobv, integer *m, - integer *n, real *a, integer *lda, real *sva, integer *mv, real *v, - integer *ldv, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgesvx_(char *fact, char *trans, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, - char *equed, real *r__, real *c__, real *b, integer *ldb, real *x, - integer *ldx, real *rcond, real *ferr, real *berr, real *work, - integer *iwork, integer *info); - -/* Subroutine */ int sgesvxx_(char *fact, char *trans, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, - char *equed, real *r__, real *c__, real *b, integer *ldb, real *x, - integer *ldx, real *rcond, real *rpvgrw, real *berr, integer * - n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer * - nparams, real *params, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sgetc2_(integer *n, real *a, integer *lda, integer *ipiv, - integer *jpiv, integer *info); - -/* Subroutine */ int sgetf2_(integer *m, integer *n, real *a, integer *lda, - integer *ipiv, integer *info); - -/* Subroutine */ int sgetrf_(integer *m, integer *n, real *a, integer *lda, - integer *ipiv, integer *info); - -/* Subroutine */ int sgetri_(integer *n, real *a, integer *lda, integer *ipiv, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgetrs_(char *trans, integer *n, integer *nrhs, real *a, - integer *lda, integer *ipiv, real *b, integer *ldb, integer *info); - -/* Subroutine */ int sggbak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, real *lscale, real *rscale, integer *m, real *v, - integer *ldv, integer *info); - -/* Subroutine */ int sggbal_(char *job, integer *n, real *a, integer *lda, - real *b, integer *ldb, integer *ilo, integer *ihi, real *lscale, real - *rscale, real *work, integer *info); - -/* Subroutine */ int sgges_(char *jobvsl, char *jobvsr, char *sort, L_fp - selctg, integer *n, real *a, integer *lda, real *b, integer *ldb, - integer *sdim, real *alphar, real *alphai, real *beta, real *vsl, - integer *ldvsl, real *vsr, integer *ldvsr, real *work, integer *lwork, - logical *bwork, integer *info); - -/* Subroutine */ int sggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp - selctg, char *sense, integer *n, real *a, integer *lda, real *b, - integer *ldb, integer *sdim, real *alphar, real *alphai, real *beta, - real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *rconde, - real *rcondv, real *work, integer *lwork, integer *iwork, integer * - liwork, logical *bwork, integer *info); - -/* Subroutine */ int sggev_(char *jobvl, char *jobvr, integer *n, real *a, - integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real - *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int sggevx_(char *balanc, char *jobvl, char *jobvr, char * - sense, integer *n, real *a, integer *lda, real *b, integer *ldb, real - *alphar, real *alphai, real *beta, real *vl, integer *ldvl, real *vr, - integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *rscale, - real *abnrm, real *bbnrm, real *rconde, real *rcondv, real *work, - integer *lwork, integer *iwork, logical *bwork, integer *info); - -/* Subroutine */ int sggglm_(integer *n, integer *m, integer *p, real *a, - integer *lda, real *b, integer *ldb, real *d__, real *x, real *y, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgghrd_(char *compq, char *compz, integer *n, integer * - ilo, integer *ihi, real *a, integer *lda, real *b, integer *ldb, real - *q, integer *ldq, real *z__, integer *ldz, integer *info); - -/* Subroutine */ int sgglse_(integer *m, integer *n, integer *p, real *a, - integer *lda, real *b, integer *ldb, real *c__, real *d__, real *x, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int sggqrf_(integer *n, integer *m, integer *p, real *a, - integer *lda, real *taua, real *b, integer *ldb, real *taub, real * - work, integer *lwork, integer *info); - -/* Subroutine */ int sggrqf_(integer *m, integer *p, integer *n, real *a, - integer *lda, real *taua, real *b, integer *ldb, real *taub, real * - work, integer *lwork, integer *info); - -/* Subroutine */ int sggsvd_(char *jobu, char *jobv, char *jobq, integer *m, - integer *n, integer *p, integer *k, integer *l, real *a, integer *lda, - real *b, integer *ldb, real *alpha, real *beta, real *u, integer * - ldu, real *v, integer *ldv, real *q, integer *ldq, real *work, - integer *iwork, integer *info); - -/* Subroutine */ int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb, - real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu, - real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real * - tau, real *work, integer *info); - -/* Subroutine */ int sgsvj0_(char *jobv, integer *m, integer *n, real *a, - integer *lda, real *d__, real *sva, integer *mv, real *v, integer * - ldv, real *eps, real *sfmin, real *tol, integer *nsweep, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int sgsvj1_(char *jobv, integer *m, integer *n, integer *n1, - real *a, integer *lda, real *d__, real *sva, integer *mv, real *v, - integer *ldv, real *eps, real *sfmin, real *tol, integer *nsweep, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int sgtcon_(char *norm, integer *n, real *dl, real *d__, - real *du, real *du2, integer *ipiv, real *anorm, real *rcond, real * - work, integer *iwork, integer *info); - -/* Subroutine */ int sgtrfs_(char *trans, integer *n, integer *nrhs, real *dl, - real *d__, real *du, real *dlf, real *df, real *duf, real *du2, - integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real * - ferr, real *berr, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sgtsv_(integer *n, integer *nrhs, real *dl, real *d__, - real *du, real *b, integer *ldb, integer *info); - -/* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer * - nrhs, real *dl, real *d__, real *du, real *dlf, real *df, real *duf, - real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer * - ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, - integer *info); - -/* Subroutine */ int sgttrf_(integer *n, real *dl, real *d__, real *du, real * - du2, integer *ipiv, integer *info); - -/* Subroutine */ int sgttrs_(char *trans, integer *n, integer *nrhs, real *dl, - real *d__, real *du, real *du2, integer *ipiv, real *b, integer *ldb, - integer *info); - -/* Subroutine */ int sgtts2_(integer *itrans, integer *n, integer *nrhs, real - *dl, real *d__, real *du, real *du2, integer *ipiv, real *b, integer * - ldb); - -/* Subroutine */ int shgeqz_(char *job, char *compq, char *compz, integer *n, - integer *ilo, integer *ihi, real *h__, integer *ldh, real *t, integer - *ldt, real *alphar, real *alphai, real *beta, real *q, integer *ldq, - real *z__, integer *ldz, real *work, integer *lwork, integer *info); - -/* Subroutine */ int shsein_(char *side, char *eigsrc, char *initv, logical * - select, integer *n, real *h__, integer *ldh, real *wr, real *wi, real - *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, - real *work, integer *ifaill, integer *ifailr, integer *info); - -/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo, - integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__, - integer *ldz, real *work, integer *lwork, integer *info); - -logical sisnan_(real *sin__); - -/* Subroutine */ int sla_gbamv__(integer *trans, integer *m, integer *n, - integer *kl, integer *ku, real *alpha, real *ab, integer *ldab, real * - x, integer *incx, real *beta, real *y, integer *incy); - -doublereal sla_gbrcond__(char *trans, integer *n, integer *kl, integer *ku, - real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, - integer *cmode, real *c__, integer *info, real *work, integer *iwork, - ftnlen trans_len); - -/* Subroutine */ int sla_gbrfsx_extended__(integer *prec_type__, integer * - trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs, - real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, - logical *colequ, real *c__, real *b, integer *ldb, real *y, integer * - ldy, real *berr_out__, integer *n_norms__, real *errs_n__, real * - errs_c__, real *res, real *ayb, real *dy, real *y_tail__, real *rcond, - integer *ithresh, real *rthresh, real *dz_ub__, logical * - ignore_cwise__, integer *info); - -doublereal sla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer * - ncols, real *ab, integer *ldab, real *afb, integer *ldafb); - -/* Subroutine */ int sla_geamv__(integer *trans, integer *m, integer *n, real - *alpha, real *a, integer *lda, real *x, integer *incx, real *beta, - real *y, integer *incy); - -doublereal sla_gercond__(char *trans, integer *n, real *a, integer *lda, real - *af, integer *ldaf, integer *ipiv, integer *cmode, real *c__, integer - *info, real *work, integer *iwork, ftnlen trans_len); - -/* Subroutine */ int sla_gerfsx_extended__(integer *prec_type__, integer * - trans_type__, integer *n, integer *nrhs, real *a, integer *lda, real * - af, integer *ldaf, integer *ipiv, logical *colequ, real *c__, real *b, - integer *ldb, real *y, integer *ldy, real *berr_out__, integer * - n_norms__, real *errs_n__, real *errs_c__, real *res, real *ayb, real - *dy, real *y_tail__, real *rcond, integer *ithresh, real *rthresh, - real *dz_ub__, logical *ignore_cwise__, integer *info); - -/* Subroutine */ int sla_lin_berr__(integer *n, integer *nz, integer *nrhs, - real *res, real *ayb, real *berr); - -doublereal sla_porcond__(char *uplo, integer *n, real *a, integer *lda, real * - af, integer *ldaf, integer *cmode, real *c__, integer *info, real * - work, integer *iwork, ftnlen uplo_len); - -/* Subroutine */ int sla_porfsx_extended__(integer *prec_type__, char *uplo, - integer *n, integer *nrhs, real *a, integer *lda, real *af, integer * - ldaf, logical *colequ, real *c__, real *b, integer *ldb, real *y, - integer *ldy, real *berr_out__, integer *n_norms__, real *errs_n__, - real *errs_c__, real *res, real *ayb, real *dy, real *y_tail__, real * - rcond, integer *ithresh, real *rthresh, real *dz_ub__, logical * - ignore_cwise__, integer *info, ftnlen uplo_len); - -doublereal sla_porpvgrw__(char *uplo, integer *ncols, real *a, integer *lda, - real *af, integer *ldaf, real *work, ftnlen uplo_len); - -doublereal sla_rpvgrw__(integer *n, integer *ncols, real *a, integer *lda, - real *af, integer *ldaf); - -/* Subroutine */ int sla_syamv__(integer *uplo, integer *n, real *alpha, real - *a, integer *lda, real *x, integer *incx, real *beta, real *y, - integer *incy); - -doublereal sla_syrcond__(char *uplo, integer *n, real *a, integer *lda, real * - af, integer *ldaf, integer *ipiv, integer *cmode, real *c__, integer * - info, real *work, integer *iwork, ftnlen uplo_len); - -/* Subroutine */ int sla_syrfsx_extended__(integer *prec_type__, char *uplo, - integer *n, integer *nrhs, real *a, integer *lda, real *af, integer * - ldaf, integer *ipiv, logical *colequ, real *c__, real *b, integer * - ldb, real *y, integer *ldy, real *berr_out__, integer *n_norms__, - real *errs_n__, real *errs_c__, real *res, real *ayb, real *dy, real * - y_tail__, real *rcond, integer *ithresh, real *rthresh, real *dz_ub__, - logical *ignore_cwise__, integer *info, ftnlen uplo_len); - -doublereal sla_syrpvgrw__(char *uplo, integer *n, integer *info, real *a, - integer *lda, real *af, integer *ldaf, integer *ipiv, real *work, - ftnlen uplo_len); - -/* Subroutine */ int sla_wwaddw__(integer *n, real *x, real *y, real *w); - -/* Subroutine */ int slabad_(real *small, real *large); - -/* Subroutine */ int slabrd_(integer *m, integer *n, integer *nb, real *a, - integer *lda, real *d__, real *e, real *tauq, real *taup, real *x, - integer *ldx, real *y, integer *ldy); - -/* Subroutine */ int slacn2_(integer *n, real *v, real *x, integer *isgn, - real *est, integer *kase, integer *isave); - -/* Subroutine */ int slacon_(integer *n, real *v, real *x, integer *isgn, - real *est, integer *kase); - -/* Subroutine */ int slacpy_(char *uplo, integer *m, integer *n, real *a, - integer *lda, real *b, integer *ldb); - -/* Subroutine */ int sladiv_(real *a, real *b, real *c__, real *d__, real *p, - real *q); - -/* Subroutine */ int slae2_(real *a, real *b, real *c__, real *rt1, real *rt2); - -/* Subroutine */ int slaebz_(integer *ijob, integer *nitmax, integer *n, - integer *mmax, integer *minp, integer *nbmin, real *abstol, real * - reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval, - real *ab, real *c__, integer *mout, integer *nab, real *work, integer - *iwork, integer *info); - -/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real - *d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs, - real *work, integer *iwork, integer *info); - -/* Subroutine */ int slaed1_(integer *n, real *d__, real *q, integer *ldq, - integer *indxq, real *rho, integer *cutpnt, real *work, integer * - iwork, integer *info); - -/* Subroutine */ int slaed2_(integer *k, integer *n, integer *n1, real *d__, - real *q, integer *ldq, integer *indxq, real *rho, real *z__, real * - dlamda, real *w, real *q2, integer *indx, integer *indxc, integer * - indxp, integer *coltyp, integer *info); - -/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__, - real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer * - indx, integer *ctot, real *w, real *s, integer *info); - -/* Subroutine */ int slaed4_(integer *n, integer *i__, real *d__, real *z__, - real *delta, real *rho, real *dlam, integer *info); - -/* Subroutine */ int slaed5_(integer *i__, real *d__, real *z__, real *delta, - real *rho, real *dlam); - -/* Subroutine */ int slaed6_(integer *kniter, logical *orgati, real *rho, - real *d__, real *z__, real *finit, real *tau, integer *info); - -/* Subroutine */ int slaed7_(integer *icompq, integer *n, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, real *d__, real *q, - integer *ldq, integer *indxq, real *rho, integer *cutpnt, real * - qstore, integer *qptr, integer *prmptr, integer *perm, integer * - givptr, integer *givcol, real *givnum, real *work, integer *iwork, - integer *info); - -/* Subroutine */ int slaed8_(integer *icompq, integer *k, integer *n, integer - *qsiz, real *d__, real *q, integer *ldq, integer *indxq, real *rho, - integer *cutpnt, real *z__, real *dlamda, real *q2, integer *ldq2, - real *w, integer *perm, integer *givptr, integer *givcol, real * - givnum, integer *indxp, integer *indx, integer *info); - -/* Subroutine */ int slaed9_(integer *k, integer *kstart, integer *kstop, - integer *n, real *d__, real *q, integer *ldq, real *rho, real *dlamda, - real *w, real *s, integer *lds, integer *info); - -/* Subroutine */ int slaeda_(integer *n, integer *tlvls, integer *curlvl, - integer *curpbm, integer *prmptr, integer *perm, integer *givptr, - integer *givcol, real *givnum, real *q, integer *qptr, real *z__, - real *ztemp, integer *info); - -/* Subroutine */ int slaein_(logical *rightv, logical *noinit, integer *n, - real *h__, integer *ldh, real *wr, real *wi, real *vr, real *vi, real - *b, integer *ldb, real *work, real *eps3, real *smlnum, real *bignum, - integer *info); - -/* Subroutine */ int slaev2_(real *a, real *b, real *c__, real *rt1, real * - rt2, real *cs1, real *sn1); - -/* Subroutine */ int slaexc_(logical *wantq, integer *n, real *t, integer * - ldt, real *q, integer *ldq, integer *j1, integer *n1, integer *n2, - real *work, integer *info); - -/* Subroutine */ int slag2_(real *a, integer *lda, real *b, integer *ldb, - real *safmin, real *scale1, real *scale2, real *wr1, real *wr2, real * - wi); - -/* Subroutine */ int slag2d_(integer *m, integer *n, real *sa, integer *ldsa, - doublereal *a, integer *lda, integer *info); - -/* Subroutine */ int slags2_(logical *upper, real *a1, real *a2, real *a3, - real *b1, real *b2, real *b3, real *csu, real *snu, real *csv, real * - snv, real *csq, real *snq); - -/* Subroutine */ int slagtf_(integer *n, real *a, real *lambda, real *b, real - *c__, real *tol, real *d__, integer *in, integer *info); - -/* Subroutine */ int slagtm_(char *trans, integer *n, integer *nrhs, real * - alpha, real *dl, real *d__, real *du, real *x, integer *ldx, real * - beta, real *b, integer *ldb); - -/* Subroutine */ int slagts_(integer *job, integer *n, real *a, real *b, real - *c__, real *d__, integer *in, real *y, real *tol, integer *info); - -/* Subroutine */ int slagv2_(real *a, integer *lda, real *b, integer *ldb, - real *alphar, real *alphai, real *beta, real *csl, real *snl, real * - csr, real *snr); - -/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * - wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer * - info); - -/* Subroutine */ int slahr2_(integer *n, integer *k, integer *nb, real *a, - integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy); - -/* Subroutine */ int slahrd_(integer *n, integer *k, integer *nb, real *a, - integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy); - -/* Subroutine */ int slaic1_(integer *job, integer *j, real *x, real *sest, - real *w, real *gamma, real *sestpr, real *s, real *c__); - -logical slaisnan_(real *sin1, real *sin2); - -/* Subroutine */ int slaln2_(logical *ltrans, integer *na, integer *nw, real * - smin, real *ca, real *a, integer *lda, real *d1, real *d2, real *b, - integer *ldb, real *wr, real *wi, real *x, integer *ldx, real *scale, - real *xnorm, integer *info); - -/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx, - integer *ldbx, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real * - difl, real *difr, real *z__, integer *k, real *c__, real *s, real * - work, integer *info); - -/* Subroutine */ int slalsa_(integer *icompq, integer *smlsiz, integer *n, - integer *nrhs, real *b, integer *ldb, real *bx, integer *ldbx, real * - u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real * - z__, real *poles, integer *givptr, integer *givcol, integer *ldgcol, - integer *perm, real *givnum, real *c__, real *s, real *work, integer * - iwork, integer *info); - -/* Subroutine */ int slalsd_(char *uplo, integer *smlsiz, integer *n, integer - *nrhs, real *d__, real *e, real *b, integer *ldb, real *rcond, - integer *rank, real *work, integer *iwork, integer *info); - -/* Subroutine */ int slamrg_(integer *n1, integer *n2, real *a, integer * - strd1, integer *strd2, integer *index); - -integer slaneg_(integer *n, real *d__, real *lld, real *sigma, real *pivmin, - integer *r__); - -doublereal slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab, - integer *ldab, real *work); - -doublereal slange_(char *norm, integer *m, integer *n, real *a, integer *lda, - real *work); - -doublereal slangt_(char *norm, integer *n, real *dl, real *d__, real *du); - -doublereal slanhs_(char *norm, integer *n, real *a, integer *lda, real *work); - -doublereal slansb_(char *norm, char *uplo, integer *n, integer *k, real *ab, - integer *ldab, real *work); - -doublereal slansf_(char *norm, char *transr, char *uplo, integer *n, real *a, - real *work); - -doublereal slansp_(char *norm, char *uplo, integer *n, real *ap, real *work); - -doublereal slanst_(char *norm, integer *n, real *d__, real *e); - -doublereal slansy_(char *norm, char *uplo, integer *n, real *a, integer *lda, - real *work); - -doublereal slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, - real *ab, integer *ldab, real *work); - -doublereal slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap, - real *work); - -doublereal slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, - real *a, integer *lda, real *work); - -/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real * - rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn); - -/* Subroutine */ int slapll_(integer *n, real *x, integer *incx, real *y, - integer *incy, real *ssmin); - -/* Subroutine */ int slapmt_(logical *forwrd, integer *m, integer *n, real *x, - integer *ldx, integer *k); - -doublereal slapy2_(real *x, real *y); - -doublereal slapy3_(real *x, real *y, real *z__); - -/* Subroutine */ int slaqgb_(integer *m, integer *n, integer *kl, integer *ku, - real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real * - colcnd, real *amax, char *equed); - -/* Subroutine */ int slaqge_(integer *m, integer *n, real *a, integer *lda, - real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, char * - equed); - -/* Subroutine */ int slaqp2_(integer *m, integer *n, integer *offset, real *a, - integer *lda, integer *jpvt, real *tau, real *vn1, real *vn2, real * - work); - -/* Subroutine */ int slaqps_(integer *m, integer *n, integer *offset, integer - *nb, integer *kb, real *a, integer *lda, integer *jpvt, real *tau, - real *vn1, real *vn2, real *auxv, real *f, integer *ldf); - -/* Subroutine */ int slaqr0_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * - wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int slaqr1_(integer *n, real *h__, integer *ldh, real *sr1, - real *si1, real *sr2, real *si2, real *v); - -/* Subroutine */ int slaqr2_(logical *wantt, logical *wantz, integer *n, - integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, - integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, - integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, - real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * - work, integer *lwork); - -/* Subroutine */ int slaqr3_(logical *wantt, logical *wantz, integer *n, - integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, - integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, - integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, - real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * - work, integer *lwork); - -/* Subroutine */ int slaqr4_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * - wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int slaqr5_(logical *wantt, logical *wantz, integer *kacc22, - integer *n, integer *ktop, integer *kbot, integer *nshfts, real *sr, - real *si, real *h__, integer *ldh, integer *iloz, integer *ihiz, real - *z__, integer *ldz, real *v, integer *ldv, real *u, integer *ldu, - integer *nv, real *wv, integer *ldwv, integer *nh, real *wh, integer * - ldwh); - -/* Subroutine */ int slaqsb_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, real *s, real *scond, real *amax, char *equed); - -/* Subroutine */ int slaqsp_(char *uplo, integer *n, real *ap, real *s, real * - scond, real *amax, char *equed); - -/* Subroutine */ int slaqsy_(char *uplo, integer *n, real *a, integer *lda, - real *s, real *scond, real *amax, char *equed); - -/* Subroutine */ int slaqtr_(logical *ltran, logical *lreal, integer *n, real - *t, integer *ldt, real *b, real *w, real *scale, real *x, real *work, - integer *info); - -/* Subroutine */ int slar1v_(integer *n, integer *b1, integer *bn, real * - lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real * - gaptol, real *z__, logical *wantnc, integer *negcnt, real *ztz, real * - mingma, integer *r__, integer *isuppz, real *nrminv, real *resid, - real *rqcorr, real *work); - -/* Subroutine */ int slar2v_(integer *n, real *x, real *y, real *z__, integer - *incx, real *c__, real *s, integer *incc); - -/* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v, - integer *incv, real *tau, real *c__, integer *ldc, real *work); - -/* Subroutine */ int slarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, real *v, integer *ldv, - real *t, integer *ldt, real *c__, integer *ldc, real *work, integer * - ldwork); - -/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx, - real *tau); - -/* Subroutine */ int slarfp_(integer *n, real *alpha, real *x, integer *incx, - real *tau); - -/* Subroutine */ int slarft_(char *direct, char *storev, integer *n, integer * - k, real *v, integer *ldv, real *tau, real *t, integer *ldt); - -/* Subroutine */ int slarfx_(char *side, integer *m, integer *n, real *v, - real *tau, real *c__, integer *ldc, real *work); - -/* Subroutine */ int slargv_(integer *n, real *x, integer *incx, real *y, - integer *incy, real *c__, integer *incc); - -/* Subroutine */ int slarnv_(integer *idist, integer *iseed, integer *n, real - *x); - -/* Subroutine */ int slarra_(integer *n, real *d__, real *e, real *e2, real * - spltol, real *tnrm, integer *nsplit, integer *isplit, integer *info); - -/* Subroutine */ int slarrb_(integer *n, real *d__, real *lld, integer * - ifirst, integer *ilast, real *rtol1, real *rtol2, integer *offset, - real *w, real *wgap, real *werr, real *work, integer *iwork, real * - pivmin, real *spdiam, integer *twist, integer *info); - -/* Subroutine */ int slarrc_(char *jobt, integer *n, real *vl, real *vu, real - *d__, real *e, real *pivmin, integer *eigcnt, integer *lcnt, integer * - rcnt, integer *info); - -/* Subroutine */ int slarrd_(char *range, char *order, integer *n, real *vl, - real *vu, integer *il, integer *iu, real *gers, real *reltol, real * - d__, real *e, real *e2, real *pivmin, integer *nsplit, integer * - isplit, integer *m, real *w, real *werr, real *wl, real *wu, integer * - iblock, integer *indexw, real *work, integer *iwork, integer *info); - -/* Subroutine */ int slarre_(char *range, integer *n, real *vl, real *vu, - integer *il, integer *iu, real *d__, real *e, real *e2, real *rtol1, - real *rtol2, real *spltol, integer *nsplit, integer *isplit, integer * - m, real *w, real *werr, real *wgap, integer *iblock, integer *indexw, - real *gers, real *pivmin, real *work, integer *iwork, integer *info); - -/* Subroutine */ int slarrf_(integer *n, real *d__, real *l, real *ld, - integer *clstrt, integer *clend, real *w, real *wgap, real *werr, - real *spdiam, real *clgapl, real *clgapr, real *pivmin, real *sigma, - real *dplus, real *lplus, real *work, integer *info); - -/* Subroutine */ int slarrj_(integer *n, real *d__, real *e2, integer *ifirst, - integer *ilast, real *rtol, integer *offset, real *w, real *werr, - real *work, integer *iwork, real *pivmin, real *spdiam, integer *info); - -/* Subroutine */ int slarrk_(integer *n, integer *iw, real *gl, real *gu, - real *d__, real *e2, real *pivmin, real *reltol, real *w, real *werr, - integer *info); - -/* Subroutine */ int slarrr_(integer *n, real *d__, real *e, integer *info); - -/* Subroutine */ int slarrv_(integer *n, real *vl, real *vu, real *d__, real * - l, real *pivmin, integer *isplit, integer *m, integer *dol, integer * - dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr, - real *wgap, integer *iblock, integer *indexw, real *gers, real *z__, - integer *ldz, integer *isuppz, real *work, integer *iwork, integer * - info); - -/* Subroutine */ int slarscl2_(integer *m, integer *n, real *d__, real *x, - integer *ldx); - -/* Subroutine */ int slartg_(real *f, real *g, real *cs, real *sn, real *r__); - -/* Subroutine */ int slartv_(integer *n, real *x, integer *incx, real *y, - integer *incy, real *c__, real *s, integer *incc); - -/* Subroutine */ int slaruv_(integer *iseed, integer *n, real *x); - -/* Subroutine */ int slarz_(char *side, integer *m, integer *n, integer *l, - real *v, integer *incv, real *tau, real *c__, integer *ldc, real * - work); - -/* Subroutine */ int slarzb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, integer *l, real *v, - integer *ldv, real *t, integer *ldt, real *c__, integer *ldc, real * - work, integer *ldwork); - -/* Subroutine */ int slarzt_(char *direct, char *storev, integer *n, integer * - k, real *v, integer *ldv, real *tau, real *t, integer *ldt); - -/* Subroutine */ int slas2_(real *f, real *g, real *h__, real *ssmin, real * - ssmax); - -/* Subroutine */ int slascl_(char *type__, integer *kl, integer *ku, real * - cfrom, real *cto, integer *m, integer *n, real *a, integer *lda, - integer *info); - -/* Subroutine */ int slascl2_(integer *m, integer *n, real *d__, real *x, - integer *ldx); - -/* Subroutine */ int slasd0_(integer *n, integer *sqre, real *d__, real *e, - real *u, integer *ldu, real *vt, integer *ldvt, integer *smlsiz, - integer *iwork, real *work, integer *info); - -/* Subroutine */ int slasd1_(integer *nl, integer *nr, integer *sqre, real * - d__, real *alpha, real *beta, real *u, integer *ldu, real *vt, - integer *ldvt, integer *idxq, integer *iwork, real *work, integer * - info); - -/* Subroutine */ int slasd2_(integer *nl, integer *nr, integer *sqre, integer - *k, real *d__, real *z__, real *alpha, real *beta, real *u, integer * - ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2, - real *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc, - integer *idxq, integer *coltyp, integer *info); - -/* Subroutine */ int slasd3_(integer *nl, integer *nr, integer *sqre, integer - *k, real *d__, real *q, integer *ldq, real *dsigma, real *u, integer * - ldu, real *u2, integer *ldu2, real *vt, integer *ldvt, real *vt2, - integer *ldvt2, integer *idxc, integer *ctot, real *z__, integer * - info); - -/* Subroutine */ int slasd4_(integer *n, integer *i__, real *d__, real *z__, - real *delta, real *rho, real *sigma, real *work, integer *info); - -/* Subroutine */ int slasd5_(integer *i__, real *d__, real *z__, real *delta, - real *rho, real *dsigma, real *work); - -/* Subroutine */ int slasd6_(integer *icompq, integer *nl, integer *nr, - integer *sqre, real *d__, real *vf, real *vl, real *alpha, real *beta, - integer *idxq, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real * - difl, real *difr, real *z__, integer *k, real *c__, real *s, real * - work, integer *iwork, integer *info); - -/* Subroutine */ int slasd7_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *k, real *d__, real *z__, real *zw, real *vf, - real *vfw, real *vl, real *vlw, real *alpha, real *beta, real *dsigma, - integer *idx, integer *idxp, integer *idxq, integer *perm, integer * - givptr, integer *givcol, integer *ldgcol, real *givnum, integer * - ldgnum, real *c__, real *s, integer *info); - -/* Subroutine */ int slasd8_(integer *icompq, integer *k, real *d__, real * - z__, real *vf, real *vl, real *difl, real *difr, integer *lddifr, - real *dsigma, real *work, integer *info); - -/* Subroutine */ int slasda_(integer *icompq, integer *smlsiz, integer *n, - integer *sqre, real *d__, real *e, real *u, integer *ldu, real *vt, - integer *k, real *difl, real *difr, real *z__, real *poles, integer * - givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum, - real *c__, real *s, real *work, integer *iwork, integer *info); - -/* Subroutine */ int slasdq_(char *uplo, integer *sqre, integer *n, integer * - ncvt, integer *nru, integer *ncc, real *d__, real *e, real *vt, - integer *ldvt, real *u, integer *ldu, real *c__, integer *ldc, real * - work, integer *info); - -/* Subroutine */ int slasdt_(integer *n, integer *lvl, integer *nd, integer * - inode, integer *ndiml, integer *ndimr, integer *msub); - -/* Subroutine */ int slaset_(char *uplo, integer *m, integer *n, real *alpha, - real *beta, real *a, integer *lda); - -/* Subroutine */ int slasq1_(integer *n, real *d__, real *e, real *work, - integer *info); - -/* Subroutine */ int slasq2_(integer *n, real *z__, integer *info); - -/* Subroutine */ int slasq3_(integer *i0, integer *n0, real *z__, integer *pp, - real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail, - integer *iter, integer *ndiv, logical *ieee, integer *ttype, real * - dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real * - tau); - -/* Subroutine */ int slasq4_(integer *i0, integer *n0, real *z__, integer *pp, - integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn, - real *dn1, real *dn2, real *tau, integer *ttype, real *g); - -/* Subroutine */ int slasq5_(integer *i0, integer *n0, real *z__, integer *pp, - real *tau, real *dmin__, real *dmin1, real *dmin2, real *dn, real * - dnm1, real *dnm2, logical *ieee); - -/* Subroutine */ int slasq6_(integer *i0, integer *n0, real *z__, integer *pp, - real *dmin__, real *dmin1, real *dmin2, real *dn, real *dnm1, real * - dnm2); - -/* Subroutine */ int slasr_(char *side, char *pivot, char *direct, integer *m, - integer *n, real *c__, real *s, real *a, integer *lda); - -/* Subroutine */ int slasrt_(char *id, integer *n, real *d__, integer *info); - -/* Subroutine */ int slassq_(integer *n, real *x, integer *incx, real *scale, - real *sumsq); - -/* Subroutine */ int slasv2_(real *f, real *g, real *h__, real *ssmin, real * - ssmax, real *snr, real *csr, real *snl, real *csl); - -/* Subroutine */ int slaswp_(integer *n, real *a, integer *lda, integer *k1, - integer *k2, integer *ipiv, integer *incx); - -/* Subroutine */ int slasy2_(logical *ltranl, logical *ltranr, integer *isgn, - integer *n1, integer *n2, real *tl, integer *ldtl, real *tr, integer * - ldtr, real *b, integer *ldb, real *scale, real *x, integer *ldx, real - *xnorm, integer *info); - -/* Subroutine */ int slasyf_(char *uplo, integer *n, integer *nb, integer *kb, - real *a, integer *lda, integer *ipiv, real *w, integer *ldw, integer - *info); - -/* Subroutine */ int slatbs_(char *uplo, char *trans, char *diag, char * - normin, integer *n, integer *kd, real *ab, integer *ldab, real *x, - real *scale, real *cnorm, integer *info); - -/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer * - ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer * - jpiv); - -/* Subroutine */ int slatps_(char *uplo, char *trans, char *diag, char * - normin, integer *n, real *ap, real *x, real *scale, real *cnorm, - integer *info); - -/* Subroutine */ int slatrd_(char *uplo, integer *n, integer *nb, real *a, - integer *lda, real *e, real *tau, real *w, integer *ldw); - -/* Subroutine */ int slatrs_(char *uplo, char *trans, char *diag, char * - normin, integer *n, real *a, integer *lda, real *x, real *scale, real - *cnorm, integer *info); - -/* Subroutine */ int slatrz_(integer *m, integer *n, integer *l, real *a, - integer *lda, real *tau, real *work); - -/* Subroutine */ int slatzm_(char *side, integer *m, integer *n, real *v, - integer *incv, real *tau, real *c1, real *c2, integer *ldc, real * - work); - -/* Subroutine */ int slauu2_(char *uplo, integer *n, real *a, integer *lda, - integer *info); - -/* Subroutine */ int slauum_(char *uplo, integer *n, real *a, integer *lda, - integer *info); - -/* Subroutine */ int sopgtr_(char *uplo, integer *n, real *ap, real *tau, - real *q, integer *ldq, real *work, integer *info); - -/* Subroutine */ int sopmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, real *ap, real *tau, real *c__, integer *ldc, real *work, - integer *info); - -/* Subroutine */ int sorg2l_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info); - -/* Subroutine */ int sorg2r_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info); - -/* Subroutine */ int sorgbr_(char *vect, integer *m, integer *n, integer *k, - real *a, integer *lda, real *tau, real *work, integer *lwork, integer - *info); - -/* Subroutine */ int sorghr_(integer *n, integer *ilo, integer *ihi, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sorgl2_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info); - -/* Subroutine */ int sorglq_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sorgql_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sorgqr_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sorgr2_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info); - -/* Subroutine */ int sorgrq_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sorgtr_(char *uplo, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sorm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *info); - -/* Subroutine */ int sorm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *info); - -/* Subroutine */ int sormbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, real *a, integer *lda, real *tau, real *c__, - integer *ldc, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sormhr_(char *side, char *trans, integer *m, integer *n, - integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real * - c__, integer *ldc, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sorml2_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *info); - -/* Subroutine */ int sormlq_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int sormql_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int sormqr_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int sormr2_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *info); - -/* Subroutine */ int sormr3_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, real *a, integer *lda, real *tau, real *c__, - integer *ldc, real *work, integer *info); - -/* Subroutine */ int sormrq_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int sormrz_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, real *a, integer *lda, real *tau, real *c__, - integer *ldc, real *work, integer *lwork, integer *info); - -/* Subroutine */ int sormtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info); - -/* Subroutine */ int spbcon_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, real *anorm, real *rcond, real *work, integer *iwork, - integer *info); - -/* Subroutine */ int spbequ_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, real *s, real *scond, real *amax, integer *info); - -/* Subroutine */ int spbrfs_(char *uplo, integer *n, integer *kd, integer * - nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, real *b, - integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real * - work, integer *iwork, integer *info); - -/* Subroutine */ int spbstf_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, integer *info); - -/* Subroutine */ int spbsv_(char *uplo, integer *n, integer *kd, integer * - nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info); - -/* Subroutine */ int spbsvx_(char *fact, char *uplo, integer *n, integer *kd, - integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, - char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx, - real *rcond, real *ferr, real *berr, real *work, integer *iwork, - integer *info); - -/* Subroutine */ int spbtf2_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, integer *info); - -/* Subroutine */ int spbtrf_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, integer *info); - -/* Subroutine */ int spbtrs_(char *uplo, integer *n, integer *kd, integer * - nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info); - -/* Subroutine */ int spftrf_(char *transr, char *uplo, integer *n, real *a, - integer *info); - -/* Subroutine */ int spftri_(char *transr, char *uplo, integer *n, real *a, - integer *info); - -/* Subroutine */ int spftrs_(char *transr, char *uplo, integer *n, integer * - nrhs, real *a, real *b, integer *ldb, integer *info); - -/* Subroutine */ int spocon_(char *uplo, integer *n, real *a, integer *lda, - real *anorm, real *rcond, real *work, integer *iwork, integer *info); - -/* Subroutine */ int spoequ_(integer *n, real *a, integer *lda, real *s, real - *scond, real *amax, integer *info); - -/* Subroutine */ int spoequb_(integer *n, real *a, integer *lda, real *s, - real *scond, real *amax, integer *info); - -/* Subroutine */ int sporfs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *af, integer *ldaf, real *b, integer *ldb, real *x, - integer *ldx, real *ferr, real *berr, real *work, integer *iwork, - integer *info); - -/* Subroutine */ int sporfsx_(char *uplo, char *equed, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, real *s, real * - b, integer *ldb, real *x, integer *ldx, real *rcond, real *berr, - integer *n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, - integer *nparams, real *params, real *work, integer *iwork, integer * - info); - -/* Subroutine */ int sposv_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, integer *info); - -/* Subroutine */ int sposvx_(char *fact, char *uplo, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed, - real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, - real *ferr, real *berr, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sposvxx_(char *fact, char *uplo, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed, - real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, - real *rpvgrw, real *berr, integer *n_err_bnds__, real * - err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real * - params, real *work, integer *iwork, integer *info); - -/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda, - integer *info); - -/* Subroutine */ int spotrf_(char *uplo, integer *n, real *a, integer *lda, - integer *info); - -/* Subroutine */ int spotri_(char *uplo, integer *n, real *a, integer *lda, - integer *info); - -/* Subroutine */ int spotrs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, integer *info); - -/* Subroutine */ int sppcon_(char *uplo, integer *n, real *ap, real *anorm, - real *rcond, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sppequ_(char *uplo, integer *n, real *ap, real *s, real * - scond, real *amax, integer *info); - -/* Subroutine */ int spprfs_(char *uplo, integer *n, integer *nrhs, real *ap, - real *afp, real *b, integer *ldb, real *x, integer *ldx, real *ferr, - real *berr, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sppsv_(char *uplo, integer *n, integer *nrhs, real *ap, - real *b, integer *ldb, integer *info); - -/* Subroutine */ int sppsvx_(char *fact, char *uplo, integer *n, integer * - nrhs, real *ap, real *afp, char *equed, real *s, real *b, integer * - ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real - *work, integer *iwork, integer *info); - -/* Subroutine */ int spptrf_(char *uplo, integer *n, real *ap, integer *info); - -/* Subroutine */ int spptri_(char *uplo, integer *n, real *ap, integer *info); - -/* Subroutine */ int spptrs_(char *uplo, integer *n, integer *nrhs, real *ap, - real *b, integer *ldb, integer *info); - -/* Subroutine */ int spstf2_(char *uplo, integer *n, real *a, integer *lda, - integer *piv, integer *rank, real *tol, real *work, integer *info); - -/* Subroutine */ int spstrf_(char *uplo, integer *n, real *a, integer *lda, - integer *piv, integer *rank, real *tol, real *work, integer *info); - -/* Subroutine */ int sptcon_(integer *n, real *d__, real *e, real *anorm, - real *rcond, real *work, integer *info); - -/* Subroutine */ int spteqr_(char *compz, integer *n, real *d__, real *e, - real *z__, integer *ldz, real *work, integer *info); - -/* Subroutine */ int sptrfs_(integer *n, integer *nrhs, real *d__, real *e, - real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx, - real *ferr, real *berr, real *work, integer *info); - -/* Subroutine */ int sptsv_(integer *n, integer *nrhs, real *d__, real *e, - real *b, integer *ldb, integer *info); - -/* Subroutine */ int sptsvx_(char *fact, integer *n, integer *nrhs, real *d__, - real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer - *ldx, real *rcond, real *ferr, real *berr, real *work, integer *info); - -/* Subroutine */ int spttrf_(integer *n, real *d__, real *e, integer *info); - -/* Subroutine */ int spttrs_(integer *n, integer *nrhs, real *d__, real *e, - real *b, integer *ldb, integer *info); - -/* Subroutine */ int sptts2_(integer *n, integer *nrhs, real *d__, real *e, - real *b, integer *ldb); - -/* Subroutine */ int srscl_(integer *n, real *sa, real *sx, integer *incx); - -/* Subroutine */ int ssbev_(char *jobz, char *uplo, integer *n, integer *kd, - real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work, - integer *info); - -/* Subroutine */ int ssbevd_(char *jobz, char *uplo, integer *n, integer *kd, - real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int ssbevx_(char *jobz, char *range, char *uplo, integer *n, - integer *kd, real *ab, integer *ldab, real *q, integer *ldq, real *vl, - real *vu, integer *il, integer *iu, real *abstol, integer *m, real * - w, real *z__, integer *ldz, real *work, integer *iwork, integer * - ifail, integer *info); - -/* Subroutine */ int ssbgst_(char *vect, char *uplo, integer *n, integer *ka, - integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real * - x, integer *ldx, real *work, integer *info); - -/* Subroutine */ int ssbgv_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real * - w, real *z__, integer *ldz, real *work, integer *info); - -/* Subroutine */ int ssbgvd_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real * - w, real *z__, integer *ldz, real *work, integer *lwork, integer * - iwork, integer *liwork, integer *info); - -/* Subroutine */ int ssbgvx_(char *jobz, char *range, char *uplo, integer *n, - integer *ka, integer *kb, real *ab, integer *ldab, real *bb, integer * - ldbb, real *q, integer *ldq, real *vl, real *vu, integer *il, integer - *iu, real *abstol, integer *m, real *w, real *z__, integer *ldz, real - *work, integer *iwork, integer *ifail, integer *info); - -/* Subroutine */ int ssbtrd_(char *vect, char *uplo, integer *n, integer *kd, - real *ab, integer *ldab, real *d__, real *e, real *q, integer *ldq, - real *work, integer *info); - -/* Subroutine */ int ssfrk_(char *transr, char *uplo, char *trans, integer *n, - integer *k, real *alpha, real *a, integer *lda, real *beta, real * - c__); - -/* Subroutine */ int sspcon_(char *uplo, integer *n, real *ap, integer *ipiv, - real *anorm, real *rcond, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sspev_(char *jobz, char *uplo, integer *n, real *ap, - real *w, real *z__, integer *ldz, real *work, integer *info); - -/* Subroutine */ int sspevd_(char *jobz, char *uplo, integer *n, real *ap, - real *w, real *z__, integer *ldz, real *work, integer *lwork, integer - *iwork, integer *liwork, integer *info); - -/* Subroutine */ int sspevx_(char *jobz, char *range, char *uplo, integer *n, - real *ap, real *vl, real *vu, integer *il, integer *iu, real *abstol, - integer *m, real *w, real *z__, integer *ldz, real *work, integer * - iwork, integer *ifail, integer *info); - -/* Subroutine */ int sspgst_(integer *itype, char *uplo, integer *n, real *ap, - real *bp, integer *info); - -/* Subroutine */ int sspgv_(integer *itype, char *jobz, char *uplo, integer * - n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work, - integer *info); - -/* Subroutine */ int sspgvd_(integer *itype, char *jobz, char *uplo, integer * - n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int sspgvx_(integer *itype, char *jobz, char *range, char * - uplo, integer *n, real *ap, real *bp, real *vl, real *vu, integer *il, - integer *iu, real *abstol, integer *m, real *w, real *z__, integer * - ldz, real *work, integer *iwork, integer *ifail, integer *info); - -/* Subroutine */ int ssprfs_(char *uplo, integer *n, integer *nrhs, real *ap, - real *afp, integer *ipiv, real *b, integer *ldb, real *x, integer * - ldx, real *ferr, real *berr, real *work, integer *iwork, integer * - info); - -/* Subroutine */ int sspsv_(char *uplo, integer *n, integer *nrhs, real *ap, - integer *ipiv, real *b, integer *ldb, integer *info); - -/* Subroutine */ int sspsvx_(char *fact, char *uplo, integer *n, integer * - nrhs, real *ap, real *afp, integer *ipiv, real *b, integer *ldb, real - *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, - integer *iwork, integer *info); - -/* Subroutine */ int ssptrd_(char *uplo, integer *n, real *ap, real *d__, - real *e, real *tau, integer *info); - -/* Subroutine */ int ssptrf_(char *uplo, integer *n, real *ap, integer *ipiv, - integer *info); - -/* Subroutine */ int ssptri_(char *uplo, integer *n, real *ap, integer *ipiv, - real *work, integer *info); - -/* Subroutine */ int ssptrs_(char *uplo, integer *n, integer *nrhs, real *ap, - integer *ipiv, real *b, integer *ldb, integer *info); - -/* Subroutine */ int sstebz_(char *range, char *order, integer *n, real *vl, - real *vu, integer *il, integer *iu, real *abstol, real *d__, real *e, - integer *m, integer *nsplit, real *w, integer *iblock, integer * - isplit, real *work, integer *iwork, integer *info); - -/* Subroutine */ int sstedc_(char *compz, integer *n, real *d__, real *e, - real *z__, integer *ldz, real *work, integer *lwork, integer *iwork, - integer *liwork, integer *info); - -/* Subroutine */ int sstegr_(char *jobz, char *range, integer *n, real *d__, - real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, - integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real * - work, integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int sstein_(integer *n, real *d__, real *e, integer *m, real - *w, integer *iblock, integer *isplit, real *z__, integer *ldz, real * - work, integer *iwork, integer *ifail, integer *info); - -/* Subroutine */ int sstemr_(char *jobz, char *range, integer *n, real *d__, - real *e, real *vl, real *vu, integer *il, integer *iu, integer *m, - real *w, real *z__, integer *ldz, integer *nzc, integer *isuppz, - logical *tryrac, real *work, integer *lwork, integer *iwork, integer * - liwork, integer *info); - -/* Subroutine */ int ssteqr_(char *compz, integer *n, real *d__, real *e, - real *z__, integer *ldz, real *work, integer *info); - -/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info); - -/* Subroutine */ int sstev_(char *jobz, integer *n, real *d__, real *e, real * - z__, integer *ldz, real *work, integer *info); - -/* Subroutine */ int sstevd_(char *jobz, integer *n, real *d__, real *e, real - *z__, integer *ldz, real *work, integer *lwork, integer *iwork, - integer *liwork, integer *info); - -/* Subroutine */ int sstevr_(char *jobz, char *range, integer *n, real *d__, - real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, - integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real * - work, integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int sstevx_(char *jobz, char *range, integer *n, real *d__, - real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, - integer *m, real *w, real *z__, integer *ldz, real *work, integer * - iwork, integer *ifail, integer *info); - -/* Subroutine */ int ssycon_(char *uplo, integer *n, real *a, integer *lda, - integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork, - integer *info); - -/* Subroutine */ int ssyequb_(char *uplo, integer *n, real *a, integer *lda, - real *s, real *scond, real *amax, real *work, integer *info); - -/* Subroutine */ int ssyev_(char *jobz, char *uplo, integer *n, real *a, - integer *lda, real *w, real *work, integer *lwork, integer *info); - -/* Subroutine */ int ssyevd_(char *jobz, char *uplo, integer *n, real *a, - integer *lda, real *w, real *work, integer *lwork, integer *iwork, - integer *liwork, integer *info); - -/* Subroutine */ int ssyevr_(char *jobz, char *range, char *uplo, integer *n, - real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, - real *abstol, integer *m, real *w, real *z__, integer *ldz, integer * - isuppz, real *work, integer *lwork, integer *iwork, integer *liwork, - integer *info); - -/* Subroutine */ int ssyevx_(char *jobz, char *range, char *uplo, integer *n, - real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, - real *abstol, integer *m, real *w, real *z__, integer *ldz, real * - work, integer *lwork, integer *iwork, integer *ifail, integer *info); - -/* Subroutine */ int ssygs2_(integer *itype, char *uplo, integer *n, real *a, - integer *lda, real *b, integer *ldb, integer *info); - -/* Subroutine */ int ssygst_(integer *itype, char *uplo, integer *n, real *a, - integer *lda, real *b, integer *ldb, integer *info); - -/* Subroutine */ int ssygv_(integer *itype, char *jobz, char *uplo, integer * - n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int ssygvd_(integer *itype, char *jobz, char *uplo, integer * - n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work, - integer *lwork, integer *iwork, integer *liwork, integer *info); - -/* Subroutine */ int ssygvx_(integer *itype, char *jobz, char *range, char * - uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, real * - vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, - real *w, real *z__, integer *ldz, real *work, integer *lwork, integer - *iwork, integer *ifail, integer *info); - -/* Subroutine */ int ssyrfs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, - integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real * - work, integer *iwork, integer *info); - -/* Subroutine */ int ssyrfsx_(char *uplo, char *equed, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, - real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, - real *berr, integer *n_err_bnds__, real *err_bnds_norm__, real * - err_bnds_comp__, integer *nparams, real *params, real *work, integer * - iwork, integer *info); - -/* Subroutine */ int ssysv_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, integer *ipiv, real *b, integer *ldb, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int ssysvx_(char *fact, char *uplo, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, - real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, - real *berr, real *work, integer *lwork, integer *iwork, integer * - info); - -/* Subroutine */ int ssysvxx_(char *fact, char *uplo, integer *n, integer * - nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, - char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx, - real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real * - err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real * - params, real *work, integer *iwork, integer *info); - -/* Subroutine */ int ssytd2_(char *uplo, integer *n, real *a, integer *lda, - real *d__, real *e, real *tau, integer *info); - -/* Subroutine */ int ssytf2_(char *uplo, integer *n, real *a, integer *lda, - integer *ipiv, integer *info); - -/* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda, - real *d__, real *e, real *tau, real *work, integer *lwork, integer * - info); - -/* Subroutine */ int ssytrf_(char *uplo, integer *n, real *a, integer *lda, - integer *ipiv, real *work, integer *lwork, integer *info); - -/* Subroutine */ int ssytri_(char *uplo, integer *n, real *a, integer *lda, - integer *ipiv, real *work, integer *info); - -/* Subroutine */ int ssytrs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, integer *ipiv, real *b, integer *ldb, integer *info); - -/* Subroutine */ int stbcon_(char *norm, char *uplo, char *diag, integer *n, - integer *kd, real *ab, integer *ldab, real *rcond, real *work, - integer *iwork, integer *info); - -/* Subroutine */ int stbrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer - *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, - integer *iwork, integer *info); - -/* Subroutine */ int stbtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer - *ldb, integer *info); - -/* Subroutine */ int stfsm_(char *transr, char *side, char *uplo, char *trans, - char *diag, integer *m, integer *n, real *alpha, real *a, real *b, - integer *ldb); - -/* Subroutine */ int stftri_(char *transr, char *uplo, char *diag, integer *n, - real *a, integer *info); - -/* Subroutine */ int stfttp_(char *transr, char *uplo, integer *n, real *arf, - real *ap, integer *info); - -/* Subroutine */ int stfttr_(char *transr, char *uplo, integer *n, real *arf, - real *a, integer *lda, integer *info); - -/* Subroutine */ int stgevc_(char *side, char *howmny, logical *select, - integer *n, real *s, integer *lds, real *p, integer *ldp, real *vl, - integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real - *work, integer *info); - -/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real - *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real * - z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work, - integer *lwork, integer *info); - -/* Subroutine */ int stgexc_(logical *wantq, logical *wantz, integer *n, real - *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real * - z__, integer *ldz, integer *ifst, integer *ilst, real *work, integer * - lwork, integer *info); - -/* Subroutine */ int stgsen_(integer *ijob, logical *wantq, logical *wantz, - logical *select, integer *n, real *a, integer *lda, real *b, integer * - ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq, - real *z__, integer *ldz, integer *m, real *pl, real *pr, real *dif, - real *work, integer *lwork, integer *iwork, integer *liwork, integer * - info); - -/* Subroutine */ int stgsja_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, integer *k, integer *l, real *a, integer *lda, - real *b, integer *ldb, real *tola, real *tolb, real *alpha, real * - beta, real *u, integer *ldu, real *v, integer *ldv, real *q, integer * - ldq, real *work, integer *ncycle, integer *info); - -/* Subroutine */ int stgsna_(char *job, char *howmny, logical *select, - integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl, - integer *ldvl, real *vr, integer *ldvr, real *s, real *dif, integer * - mm, integer *m, real *work, integer *lwork, integer *iwork, integer * - info); - -/* Subroutine */ int stgsy2_(char *trans, integer *ijob, integer *m, integer * - n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer * - ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer - *ldf, real *scale, real *rdsum, real *rdscal, integer *iwork, integer - *pq, integer *info); - -/* Subroutine */ int stgsyl_(char *trans, integer *ijob, integer *m, integer * - n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer * - ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer - *ldf, real *scale, real *dif, real *work, integer *lwork, integer * - iwork, integer *info); - -/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n, - real *ap, real *rcond, real *work, integer *iwork, integer *info); - -/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx, - real *ferr, real *berr, real *work, integer *iwork, integer *info); - -/* Subroutine */ int stptri_(char *uplo, char *diag, integer *n, real *ap, - integer *info); - -/* Subroutine */ int stptrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *ap, real *b, integer *ldb, integer *info); - -/* Subroutine */ int stpttf_(char *transr, char *uplo, integer *n, real *ap, - real *arf, integer *info); - -/* Subroutine */ int stpttr_(char *uplo, integer *n, real *ap, real *a, - integer *lda, integer *info); - -/* Subroutine */ int strcon_(char *norm, char *uplo, char *diag, integer *n, - real *a, integer *lda, real *rcond, real *work, integer *iwork, - integer *info); - -/* Subroutine */ int strevc_(char *side, char *howmny, logical *select, - integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, - integer *ldvr, integer *mm, integer *m, real *work, integer *info); - -/* Subroutine */ int strexc_(char *compq, integer *n, real *t, integer *ldt, - real *q, integer *ldq, integer *ifst, integer *ilst, real *work, - integer *info); - -/* Subroutine */ int strrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x, - integer *ldx, real *ferr, real *berr, real *work, integer *iwork, - integer *info); - -/* Subroutine */ int strsen_(char *job, char *compq, logical *select, integer - *n, real *t, integer *ldt, real *q, integer *ldq, real *wr, real *wi, - integer *m, real *s, real *sep, real *work, integer *lwork, integer * - iwork, integer *liwork, integer *info); - -/* Subroutine */ int strsna_(char *job, char *howmny, logical *select, - integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, - integer *ldvr, real *s, real *sep, integer *mm, integer *m, real * - work, integer *ldwork, integer *iwork, integer *info); - -/* Subroutine */ int strsyl_(char *trana, char *tranb, integer *isgn, integer - *m, integer *n, real *a, integer *lda, real *b, integer *ldb, real * - c__, integer *ldc, real *scale, integer *info); - -/* Subroutine */ int strti2_(char *uplo, char *diag, integer *n, real *a, - integer *lda, integer *info); - -/* Subroutine */ int strtri_(char *uplo, char *diag, integer *n, real *a, - integer *lda, integer *info); - -/* Subroutine */ int strtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer * - info); - -/* Subroutine */ int strttf_(char *transr, char *uplo, integer *n, real *a, - integer *lda, real *arf, integer *info); - -/* Subroutine */ int strttp_(char *uplo, integer *n, real *a, integer *lda, - real *ap, integer *info); - -/* Subroutine */ int stzrqf_(integer *m, integer *n, real *a, integer *lda, - real *tau, integer *info); - -/* Subroutine */ int stzrzf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info); - -/* Subroutine */ int xerbla_(char *srname, integer *info); - -/* Subroutine */ int xerbla_array__(char *srname_array__, integer * - srname_len__, integer *info, ftnlen srname_array_len); - - -/* Subroutine */ int dlamc1_(integer *beta, integer *t, logical *rnd, logical - *ieee1); - -doublereal dsecnd_(); - -/* Subroutine */ int ilaver_(integer *vers_major__, integer *vers_minor__, - integer *vers_patch__); - -doublereal second_(); - -/* Subroutine */ int slamc1_(integer *beta, integer *t, logical *rnd, logical - *ieee1); - -/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real * - eps, integer *emin, real *rmin, integer *emax, real *rmax); - -doublereal slamc3_(real *a, real *b); - -/* Subroutine */ int slamc4_(integer *emin, real *start, integer *base); - -/* Subroutine */ int slamc5_(integer *beta, integer *p, integer *emin, - logical *ieee, integer *emax, real *rmax); - - -/* Subroutine */ int dlamc1_(integer *beta, integer *t, logical *rnd, logical - *ieee1); - -/* Subroutine */ int dlamc2_(integer *beta, integer *t, logical *rnd, - doublereal *eps, integer *emin, doublereal *rmin, integer *emax, - doublereal *rmax); - -doublereal dlamc3_(doublereal *a, doublereal *b); - -/* Subroutine */ int dlamc4_(integer *emin, doublereal *start, integer *base); - -/* Subroutine */ int dlamc5_(integer *beta, integer *p, integer *emin, - logical *ieee, integer *emax, doublereal *rmax); - -#ifdef __cplusplus -} -#endif - -#endif /* __CLAPACK_H */ diff --git a/3rdparty/include/f2c.h b/3rdparty/include/f2c.h deleted file mode 100644 index 006efa4..0000000 --- a/3rdparty/include/f2c.h +++ /dev/null @@ -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 -#include -#include -#include -/* needed for Windows Mobile */ -#ifdef WINCE -#undef complex; -#endif -#include -#include - -#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 diff --git a/3rdparty/lapack/CMakeLists.txt b/3rdparty/lapack/CMakeLists.txt deleted file mode 100644 index 9ccf07c..0000000 --- a/3rdparty/lapack/CMakeLists.txt +++ /dev/null @@ -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() diff --git a/3rdparty/lapack/COPYING b/3rdparty/lapack/COPYING deleted file mode 100644 index d7bf953..0000000 --- a/3rdparty/lapack/COPYING +++ /dev/null @@ -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. - diff --git a/3rdparty/lapack/dasum.c b/3rdparty/lapack/dasum.c deleted file mode 100644 index e0ecaf5..0000000 --- a/3rdparty/lapack/dasum.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/daxpy.c b/3rdparty/lapack/daxpy.c deleted file mode 100644 index a9e2ea4..0000000 --- a/3rdparty/lapack/daxpy.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dbdsdc.c b/3rdparty/lapack/dbdsdc.c deleted file mode 100644 index 83ebb0a..0000000 --- a/3rdparty/lapack/dbdsdc.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dbdsqr.c b/3rdparty/lapack/dbdsqr.c deleted file mode 100644 index 9aa6bf8..0000000 --- a/3rdparty/lapack/dbdsqr.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dcopy.c b/3rdparty/lapack/dcopy.c deleted file mode 100644 index 4b7637c..0000000 --- a/3rdparty/lapack/dcopy.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/ddot.c b/3rdparty/lapack/ddot.c deleted file mode 100644 index 18eb516..0000000 --- a/3rdparty/lapack/ddot.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgebd2.c b/3rdparty/lapack/dgebd2.c deleted file mode 100644 index c79274f..0000000 --- a/3rdparty/lapack/dgebd2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgebrd.c b/3rdparty/lapack/dgebrd.c deleted file mode 100644 index d280627..0000000 --- a/3rdparty/lapack/dgebrd.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgelq2.c b/3rdparty/lapack/dgelq2.c deleted file mode 100644 index 399a9fc..0000000 --- a/3rdparty/lapack/dgelq2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgelqf.c b/3rdparty/lapack/dgelqf.c deleted file mode 100644 index fc62cac..0000000 --- a/3rdparty/lapack/dgelqf.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgels.c b/3rdparty/lapack/dgels.c deleted file mode 100644 index bbfee70..0000000 --- a/3rdparty/lapack/dgels.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgelsd.c b/3rdparty/lapack/dgelsd.c deleted file mode 100644 index 1738a91..0000000 --- a/3rdparty/lapack/dgelsd.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgemm.c b/3rdparty/lapack/dgemm.c deleted file mode 100644 index 3d78f04..0000000 --- a/3rdparty/lapack/dgemm.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgemv_custom.c b/3rdparty/lapack/dgemv_custom.c deleted file mode 100644 index 7a42f30..0000000 --- a/3rdparty/lapack/dgemv_custom.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgeqr2.c b/3rdparty/lapack/dgeqr2.c deleted file mode 100644 index d85f10d..0000000 --- a/3rdparty/lapack/dgeqr2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgeqrf.c b/3rdparty/lapack/dgeqrf.c deleted file mode 100644 index 0415f14..0000000 --- a/3rdparty/lapack/dgeqrf.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dger_custom.c b/3rdparty/lapack/dger_custom.c deleted file mode 100644 index 4296e02..0000000 --- a/3rdparty/lapack/dger_custom.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgesdd.c b/3rdparty/lapack/dgesdd.c deleted file mode 100644 index 2d9e594..0000000 --- a/3rdparty/lapack/dgesdd.c +++ /dev/null @@ -1,1609 +0,0 @@ -/* dgesdd.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__0 = 0; -static doublereal c_b227 = 0.; -static doublereal c_b248 = 1.; - -/* Subroutine */ int dgesdd_(char *jobz, integer *m, integer *n, doublereal * - a, integer *lda, doublereal *s, doublereal *u, integer *ldu, - doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, - integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2, i__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, ie, il, ir, iu, blk; - doublereal dum[1], eps; - integer ivt, iscl; - doublereal anrm; - integer idum[1], ierr, itau; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - extern logical lsame_(char *, char *); - integer chunk, minmn, wrkbl, itaup, itauq, mnthr; - logical wntqa; - integer nwork; - logical wntqn, wntqo, wntqs; - extern /* Subroutine */ int dbdsdc_(char *, char *, integer *, doublereal - *, doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, integer *), dgebrd_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, integer *); - extern doublereal dlamch_(char *), dlange_(char *, integer *, - integer *, doublereal *, integer *, doublereal *); - integer bdspac; - 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 *), dlacpy_(char *, - integer *, integer *, doublereal *, integer *, doublereal *, - integer *), dlaset_(char *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *), - xerbla_(char *, integer *), dorgbr_(char *, integer *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, 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 *), dorglq_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - integer *), dorgqr_(integer *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *); - integer ldwrkl, ldwrkr, minwrk, ldwrku, maxwrk, ldwkvt; - doublereal smlnum; - logical wntqas, lquery; - - -/* -- LAPACK driver 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..-- */ -/* March 2009 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGESDD computes the singular value decomposition (SVD) of a real */ -/* M-by-N matrix A, optionally computing the left and right singular */ -/* vectors. If singular vectors are desired, it uses a */ -/* divide-and-conquer algorithm. */ - -/* The SVD is written */ - -/* A = U * SIGMA * transpose(V) */ - -/* where SIGMA is an M-by-N matrix which is zero except for its */ -/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */ -/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */ -/* are the singular values of A; they are real and non-negative, and */ -/* are returned in descending order. The first min(m,n) columns of */ -/* U and V are the left and right singular vectors of A. */ - -/* Note that the routine returns VT = V**T, not V. */ - -/* 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 */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* Specifies options for computing all or part of the matrix U: */ -/* = 'A': all M columns of U and all N rows of V**T are */ -/* returned in the arrays U and VT; */ -/* = 'S': the first min(M,N) columns of U and the first */ -/* min(M,N) rows of V**T are returned in the arrays U */ -/* and VT; */ -/* = 'O': If M >= N, the first N columns of U are overwritten */ -/* on the array A and all rows of V**T are returned in */ -/* the array VT; */ -/* otherwise, all columns of U are returned in the */ -/* array U and the first M rows of V**T are overwritten */ -/* in the array A; */ -/* = 'N': no columns of U or rows of V**T are computed. */ - -/* M (input) INTEGER */ -/* The number of rows of the input matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the input matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, */ -/* if JOBZ = 'O', A is overwritten with the first N columns */ -/* of U (the left singular vectors, stored */ -/* columnwise) if M >= N; */ -/* A is overwritten with the first M rows */ -/* of V**T (the right singular vectors, stored */ -/* rowwise) otherwise. */ -/* if JOBZ .ne. 'O', the contents of A are destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The singular values of A, sorted so that S(i) >= S(i+1). */ - -/* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) */ -/* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; */ -/* UCOL = min(M,N) if JOBZ = 'S'. */ -/* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M */ -/* orthogonal matrix U; */ -/* if JOBZ = 'S', U contains the first min(M,N) columns of U */ -/* (the left singular vectors, stored columnwise); */ -/* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= 1; if */ -/* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. */ - -/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */ -/* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the */ -/* N-by-N orthogonal matrix V**T; */ -/* if JOBZ = 'S', VT contains the first min(M,N) rows of */ -/* V**T (the right singular vectors, stored rowwise); */ -/* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. LDVT >= 1; if */ -/* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; */ -/* if JOBZ = 'S', LDVT >= min(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 >= 1. */ -/* If JOBZ = 'N', */ -/* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)). */ -/* If JOBZ = 'O', */ -/* LWORK >= 3*min(M,N) + */ -/* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). */ -/* If JOBZ = 'S' or 'A' */ -/* LWORK >= 3*min(M,N) + */ -/* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)). */ -/* For good performance, LWORK should generally be larger. */ -/* If LWORK = -1 but other input arguments are legal, WORK(1) */ -/* returns the optimal LWORK. */ - -/* IWORK (workspace) INTEGER array, dimension (8*min(M,N)) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: DBDSDC did not converge, updating process failed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. 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; - --s; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - minmn = min(*m,*n); - wntqa = lsame_(jobz, "A"); - wntqs = lsame_(jobz, "S"); - wntqas = wntqa || wntqs; - wntqo = lsame_(jobz, "O"); - wntqn = lsame_(jobz, "N"); - lquery = *lwork == -1; - - if (! (wntqa || wntqs || wntqo || wntqn)) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < * - m) { - *info = -8; - } else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn || - wntqo && *m >= *n && *ldvt < *n) { - *info = -10; - } - -/* 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.) */ - - if (*info == 0) { - minwrk = 1; - maxwrk = 1; - if (*m >= *n && minmn > 0) { - -/* Compute space needed for DBDSDC */ - - mnthr = (integer) (minmn * 11. / 6.); - if (wntqn) { - bdspac = *n * 7; - } else { - bdspac = *n * 3 * *n + (*n << 2); - } - if (*m >= mnthr) { - if (wntqn) { - -/* Path 1 (M much larger than N, JOBZ='N') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n; - maxwrk = max(i__1,i__2); - minwrk = bdspac + *n; - } else if (wntqo) { - -/* Path 2 (M much larger than N, JOBZ='O') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + (*n << 1) * *n; - minwrk = bdspac + (*n << 1) * *n + *n * 3; - } else if (wntqs) { - -/* Path 3 (M much larger than N, JOBZ='S') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *n * *n; - minwrk = bdspac + *n * *n + *n * 3; - } else if (wntqa) { - -/* Path 4 (M much larger than N, JOBZ='A') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *m * ilaenv_(&c__1, "DORGQR", - " ", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *n * *n; - minwrk = bdspac + *n * *n + *n * 3; - } - } else { - -/* Path 5 (M at least N, but not much larger) */ - - wrkbl = *n * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, - n, &c_n1, &c_n1); - if (wntqn) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - maxwrk = max(i__1,i__2); - minwrk = *n * 3 + max(*m,bdspac); - } else if (wntqo) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", m, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *m * *n; -/* Computing MAX */ - i__1 = *m, i__2 = *n * *n + bdspac; - minwrk = *n * 3 + max(i__1,i__2); - } else if (wntqs) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", m, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - maxwrk = max(i__1,i__2); - minwrk = *n * 3 + max(*m,bdspac); - } else if (wntqa) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = bdspac + *n * 3; - maxwrk = max(i__1,i__2); - minwrk = *n * 3 + max(*m,bdspac); - } - } - } else if (minmn > 0) { - -/* Compute space needed for DBDSDC */ - - mnthr = (integer) (minmn * 11. / 6.); - if (wntqn) { - bdspac = *m * 7; - } else { - bdspac = *m * 3 * *m + (*m << 2); - } - if (*n >= mnthr) { - if (wntqn) { - -/* Path 1t (N much larger than M, JOBZ='N') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m; - maxwrk = max(i__1,i__2); - minwrk = bdspac + *m; - } else if (wntqo) { - -/* Path 2t (N much larger than M, JOBZ='O') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + (*m << 1) * *m; - minwrk = bdspac + (*m << 1) * *m + *m * 3; - } else if (wntqs) { - -/* Path 3t (N much larger than M, JOBZ='S') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *m * *m; - minwrk = bdspac + *m * *m + *m * 3; - } else if (wntqa) { - -/* Path 4t (N much larger than M, JOBZ='A') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *n * ilaenv_(&c__1, "DORGLQ", - " ", n, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *m * *m; - minwrk = bdspac + *m * *m + *m * 3; - } - } else { - -/* Path 5t (N greater than M, but not much larger) */ - - wrkbl = *m * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, - n, &c_n1, &c_n1); - if (wntqn) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = max(i__1,i__2); - minwrk = *m * 3 + max(*n,bdspac); - } else if (wntqo) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *m * *n; -/* Computing MAX */ - i__1 = *n, i__2 = *m * *m + bdspac; - minwrk = *m * 3 + max(i__1,i__2); - } else if (wntqs) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = max(i__1,i__2); - minwrk = *m * 3 + max(*n,bdspac); - } else if (wntqa) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = max(i__1,i__2); - minwrk = *m * 3 + max(*n,bdspac); - } - } - } - maxwrk = max(maxwrk,minwrk); - work[1] = (doublereal) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGESDD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = sqrt(dlamch_("S")) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, dum); - iscl = 0; - if (anrm > 0. && anrm < smlnum) { - iscl = 1; - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & - ierr); - } else if (anrm > bignum) { - iscl = 1; - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & - ierr); - } - - if (*m >= *n) { - -/* A has at least as many rows as columns. If A has sufficiently */ -/* more rows than columns, first reduce using the QR */ -/* decomposition (if sufficient workspace available) */ - - if (*m >= mnthr) { - - if (wntqn) { - -/* Path 1 (M much larger than N, JOBZ='N') */ -/* No singular vectors to be computed */ - - 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, &ierr); - -/* Zero out below R */ - - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_("L", &i__1, &i__2, &c_b227, &c_b227, &a[a_dim1 + 2], - lda); - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in A */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - nwork = ie + *n; - -/* Perform bidiagonal SVD, computing singular values only */ -/* (Workspace: need N+BDSPAC) */ - - dbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - - } else if (wntqo) { - -/* Path 2 (M much larger than N, JOBZ = 'O') */ -/* N left singular vectors to be overwritten on A and */ -/* N right singular vectors to be computed in VT */ - - ir = 1; - -/* WORK(IR) is LDWRKR by N */ - - if (*lwork >= *lda * *n + *n * *n + *n * 3 + bdspac) { - ldwrkr = *lda; - } else { - ldwrkr = (*lwork - *n * *n - *n * 3 - bdspac) / *n; - } - itau = ir + ldwrkr * *n; - nwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Copy R to WORK(IR), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_("L", &i__1, &i__2, &c_b227, &c_b227, &work[ir + 1], & - ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], - &i__1, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in VT, copying result to WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - -/* WORK(IU) is N by N */ - - iu = nwork; - nwork = iu + *n * *n; - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite WORK(IU) by left singular vectors of R */ -/* and VT by right singular vectors of R */ -/* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[ - itauq], &work[iu], n, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IU), storing result in WORK(IR) and copying to A */ -/* (Workspace: need 2*N*N, prefer N*N+M*N) */ - - i__1 = *m; - i__2 = ldwrkr; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = *m - i__ + 1; - chunk = min(i__3,ldwrkr); - dgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + a_dim1], - lda, &work[iu], n, &c_b227, &work[ir], &ldwrkr); - dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + - a_dim1], lda); -/* L10: */ - } - - } else if (wntqs) { - -/* Path 3 (M much larger than N, JOBZ='S') */ -/* N left singular vectors to be computed in U and */ -/* N right singular vectors to be computed in VT */ - - ir = 1; - -/* WORK(IR) is N by N */ - - ldwrkr = *n; - itau = ir + ldwrkr * *n; - nwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - -/* Copy R to WORK(IR), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); - i__2 = *n - 1; - i__1 = *n - 1; - dlaset_("L", &i__2, &i__1, &c_b227, &c_b227, &work[ir + 1], & - ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], - &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagoal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of R and VT */ -/* by right singular vectors of R */ -/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IR), storing result in U */ -/* (Workspace: need N*N) */ - - dlacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr); - dgemm_("N", "N", m, n, n, &c_b248, &a[a_offset], lda, &work[ - ir], &ldwrkr, &c_b227, &u[u_offset], ldu); - - } else if (wntqa) { - -/* Path 4 (M much larger than N, JOBZ='A') */ -/* M left singular vectors to be computed in U and */ -/* N right singular vectors to be computed in VT */ - - iu = 1; - -/* WORK(IU) is N by N */ - - ldwrku = *n; - itau = iu + ldwrku * *n; - nwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu); - -/* Generate Q in U */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - i__2 = *lwork - nwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork], - &i__2, &ierr); - -/* Produce R in A, zeroing out other entries */ - - i__2 = *n - 1; - i__1 = *n - 1; - dlaset_("L", &i__2, &i__1, &c_b227, &c_b227, &a[a_dim1 + 2], - lda); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in A */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite WORK(IU) by left singular vectors of R and VT */ -/* by right singular vectors of R */ -/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", n, n, n, &a[a_offset], lda, &work[ - itauq], &work[iu], &ldwrku, &work[nwork], &i__2, & - ierr); - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply Q in U by left singular vectors of R in */ -/* WORK(IU), storing result in A */ -/* (Workspace: need N*N) */ - - dgemm_("N", "N", m, n, n, &c_b248, &u[u_offset], ldu, &work[ - iu], &ldwrku, &c_b227, &a[a_offset], lda); - -/* Copy left singular vectors of A from A to U */ - - dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu); - - } - - } else { - -/* M .LT. MNTHR */ - -/* Path 5 (M at least N, but not much larger) */ -/* Reduce to bidiagonal form without QR decomposition */ - - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize A */ -/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__2, &ierr); - if (wntqn) { - -/* Perform bidiagonal SVD, only computing singular values */ -/* (Workspace: need N+BDSPAC) */ - - dbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - } else if (wntqo) { - iu = nwork; - if (*lwork >= *m * *n + *n * 3 + bdspac) { - -/* WORK( IU ) is M by N */ - - ldwrku = *m; - nwork = iu + ldwrku * *n; - dlaset_("F", m, n, &c_b227, &c_b227, &work[iu], &ldwrku); - } else { - -/* WORK( IU ) is N by N */ - - ldwrku = *n; - nwork = iu + ldwrku * *n; - -/* WORK(IR) is LDWRKR by N */ - - ir = nwork; - ldwrkr = (*lwork - *n * *n - *n * 3) / *n; - } - nwork = iu + ldwrku * *n; - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], &ldwrku, & - vt[vt_offset], ldvt, dum, idum, &work[nwork], &iwork[ - 1], info); - -/* Overwrite VT by right singular vectors of A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - - if (*lwork >= *m * *n + *n * 3 + bdspac) { - -/* Overwrite WORK(IU) by left singular vectors of A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[ - itauq], &work[iu], &ldwrku, &work[nwork], &i__2, & - ierr); - -/* Copy left singular vectors of A from WORK(IU) to A */ - - dlacpy_("F", m, n, &work[iu], &ldwrku, &a[a_offset], lda); - } else { - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], & - work[nwork], &i__2, &ierr); - -/* Multiply Q in A by left singular vectors of */ -/* bidiagonal matrix in WORK(IU), storing result in */ -/* WORK(IR) and copying to A */ -/* (Workspace: need 2*N*N, prefer N*N+M*N) */ - - i__2 = *m; - i__1 = ldwrkr; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { -/* Computing MIN */ - i__3 = *m - i__ + 1; - chunk = min(i__3,ldwrkr); - dgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + - a_dim1], lda, &work[iu], &ldwrku, &c_b227, & - work[ir], &ldwrkr); - dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + - a_dim1], lda); -/* L20: */ - } - } - - } else if (wntqs) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - dlaset_("F", m, n, &c_b227, &c_b227, &u[u_offset], ldu); - dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 3*N, prefer 2*N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } else if (wntqa) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - dlaset_("F", m, m, &c_b227, &c_b227, &u[u_offset], ldu); - dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Set the right corner of U to identity matrix */ - - if (*m > *n) { - i__1 = *m - *n; - i__2 = *m - *n; - dlaset_("F", &i__1, &i__2, &c_b227, &c_b248, &u[*n + 1 + ( - *n + 1) * u_dim1], ldu); - } - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } - - } - - } else { - -/* A has more columns than rows. If A has sufficiently more */ -/* columns than rows, first reduce using the LQ decomposition (if */ -/* sufficient workspace available) */ - - if (*n >= mnthr) { - - if (wntqn) { - -/* Path 1t (N much larger than M, JOBZ='N') */ -/* No singular vectors to be computed */ - - itau = 1; - nwork = itau + *m; - -/* 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, &ierr); - -/* Zero out above L */ - - i__1 = *m - 1; - i__2 = *m - 1; - dlaset_("U", &i__1, &i__2, &c_b227, &c_b227, &a[(a_dim1 << 1) - + 1], lda); - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in A */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - nwork = ie + *m; - -/* Perform bidiagonal SVD, computing singular values only */ -/* (Workspace: need M+BDSPAC) */ - - dbdsdc_("U", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - - } else if (wntqo) { - -/* Path 2t (N much larger than M, JOBZ='O') */ -/* M right singular vectors to be overwritten on A and */ -/* M left singular vectors to be computed in U */ - - ivt = 1; - -/* IVT is M by M */ - - il = ivt + *m * *m; - if (*lwork >= *m * *n + *m * *m + *m * 3 + bdspac) { - -/* WORK(IL) is M by N */ - - ldwrkl = *m; - chunk = *n; - } else { - ldwrkl = *m; - chunk = (*lwork - *m * *m) / *m; - } - itau = il + ldwrkl * *m; - nwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Copy L to WORK(IL), zeroing about above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl); - i__1 = *m - 1; - i__2 = *m - 1; - dlaset_("U", &i__1, &i__2, &c_b227, &c_b227, &work[il + - ldwrkl], &ldwrkl); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], - &i__1, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in WORK(IL) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U, and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M+M*M+BDSPAC) */ - - dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], m, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of L and WORK(IVT) */ -/* by right singular vectors of L */ -/* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[ - itaup], &work[ivt], m, &work[nwork], &i__1, &ierr); - -/* Multiply right singular vectors of L in WORK(IVT) by Q */ -/* in A, storing result in WORK(IL) and copying to A */ -/* (Workspace: need 2*M*M, prefer M*M+M*N) */ - - i__1 = *n; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = *n - i__ + 1; - blk = min(i__3,chunk); - dgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], m, &a[ - i__ * a_dim1 + 1], lda, &c_b227, &work[il], & - ldwrkl); - dlacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1 - + 1], lda); -/* L30: */ - } - - } else if (wntqs) { - -/* Path 3t (N much larger than M, JOBZ='S') */ -/* M right singular vectors to be computed in VT and */ -/* M left singular vectors to be computed in U */ - - il = 1; - -/* WORK(IL) is M by M */ - - ldwrkl = *m; - itau = il + ldwrkl * *m; - nwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - -/* Copy L to WORK(IL), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl); - i__2 = *m - 1; - i__1 = *m - 1; - dlaset_("U", &i__2, &i__1, &c_b227, &c_b227, &work[il + - ldwrkl], &ldwrkl); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], - &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in WORK(IU), copying result to U */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of L and VT */ -/* by right singular vectors of L */ -/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply right singular vectors of L in WORK(IL) by */ -/* Q in A, storing result in VT */ -/* (Workspace: need M*M) */ - - dlacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl); - dgemm_("N", "N", m, n, m, &c_b248, &work[il], &ldwrkl, &a[ - a_offset], lda, &c_b227, &vt[vt_offset], ldvt); - - } else if (wntqa) { - -/* Path 4t (N much larger than M, JOBZ='A') */ -/* N right singular vectors to be computed in VT and */ -/* M left singular vectors to be computed in U */ - - ivt = 1; - -/* WORK(IVT) is M by M */ - - ldwkvt = *m; - itau = ivt + ldwkvt * *m; - nwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); - -/* Generate Q in VT */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[ - nwork], &i__2, &ierr); - -/* Produce L in A, zeroing out other entries */ - - i__2 = *m - 1; - i__1 = *m - 1; - dlaset_("U", &i__2, &i__1, &c_b227, &c_b227, &a[(a_dim1 << 1) - + 1], lda); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in A */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M+M*M+BDSPAC) */ - - dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1] -, info); - -/* Overwrite U by left singular vectors of L and WORK(IVT) */ -/* by right singular vectors of L */ -/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, m, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, m, m, &a[a_offset], lda, &work[ - itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, & - ierr); - -/* Multiply right singular vectors of L in WORK(IVT) by */ -/* Q in VT, storing result in A */ -/* (Workspace: need M*M) */ - - dgemm_("N", "N", m, n, m, &c_b248, &work[ivt], &ldwkvt, &vt[ - vt_offset], ldvt, &c_b227, &a[a_offset], lda); - -/* Copy right singular vectors of A from A to VT */ - - dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); - - } - - } else { - -/* N .LT. MNTHR */ - -/* Path 5t (N greater than M, but not much larger) */ -/* Reduce to bidiagonal form without LQ decomposition */ - - 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__2 = *lwork - nwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__2, &ierr); - if (wntqn) { - -/* Perform bidiagonal SVD, only computing singular values */ -/* (Workspace: need M+BDSPAC) */ - - dbdsdc_("L", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - } else if (wntqo) { - ldwkvt = *m; - ivt = nwork; - if (*lwork >= *m * *n + *m * 3 + bdspac) { - -/* WORK( IVT ) is M by N */ - - dlaset_("F", m, n, &c_b227, &c_b227, &work[ivt], &ldwkvt); - nwork = ivt + ldwkvt * *n; - } else { - -/* WORK( IVT ) is M by M */ - - nwork = ivt + ldwkvt * *m; - il = nwork; - -/* WORK(IL) is M by CHUNK */ - - chunk = (*lwork - *m * *m - *m * 3) / *m; - } - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M*M+BDSPAC) */ - - dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1] -, info); - -/* Overwrite U by left singular vectors of A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - - if (*lwork >= *m * *n + *m * 3 + bdspac) { - -/* Overwrite WORK(IVT) by left singular vectors of A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[ - itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, - &ierr); - -/* Copy right singular vectors of A from WORK(IVT) to A */ - - dlacpy_("F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda); - } else { - -/* Generate P**T in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], & - work[nwork], &i__2, &ierr); - -/* Multiply Q in A by right singular vectors of */ -/* bidiagonal matrix in WORK(IVT), storing result in */ -/* WORK(IL) and copying to A */ -/* (Workspace: need 2*M*M, prefer M*M+M*N) */ - - i__2 = *n; - i__1 = chunk; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { -/* Computing MIN */ - i__3 = *n - i__ + 1; - blk = min(i__3,chunk); - dgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], & - ldwkvt, &a[i__ * a_dim1 + 1], lda, &c_b227, & - work[il], m); - dlacpy_("F", m, &blk, &work[il], m, &a[i__ * a_dim1 + - 1], lda); -/* L40: */ - } - } - } else if (wntqs) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - dlaset_("F", m, n, &c_b227, &c_b227, &vt[vt_offset], ldvt); - dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 3*M, prefer 2*M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } else if (wntqa) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - dlaset_("F", n, n, &c_b227, &c_b227, &vt[vt_offset], ldvt); - dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Set the right corner of VT to identity matrix */ - - if (*n > *m) { - i__1 = *n - *m; - i__2 = *n - *m; - dlaset_("F", &i__1, &i__2, &c_b227, &c_b248, &vt[*m + 1 + - (*m + 1) * vt_dim1], ldvt); - } - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 2*M+N, prefer 2*M+N*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } - - } - - } - -/* Undo scaling if necessary */ - - if (iscl == 1) { - if (anrm > bignum) { - dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr); - } - if (anrm < smlnum) { - dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr); - } - } - -/* Return optimal workspace in WORK(1) */ - - work[1] = (doublereal) maxwrk; - - return 0; - -/* End of DGESDD */ - -} /* dgesdd_ */ diff --git a/3rdparty/lapack/dgesv.c b/3rdparty/lapack/dgesv.c deleted file mode 100644 index 53a3257..0000000 --- a/3rdparty/lapack/dgesv.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgetf2.c b/3rdparty/lapack/dgetf2.c deleted file mode 100644 index aea4657..0000000 --- a/3rdparty/lapack/dgetf2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgetrf.c b/3rdparty/lapack/dgetrf.c deleted file mode 100644 index de76a5b..0000000 --- a/3rdparty/lapack/dgetrf.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgetri.c b/3rdparty/lapack/dgetri.c deleted file mode 100644 index 9c0467a..0000000 --- a/3rdparty/lapack/dgetri.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dgetrs.c b/3rdparty/lapack/dgetrs.c deleted file mode 100644 index 767dafe..0000000 --- a/3rdparty/lapack/dgetrs.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlabad.c b/3rdparty/lapack/dlabad.c deleted file mode 100644 index d63599b..0000000 --- a/3rdparty/lapack/dlabad.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlabrd.c b/3rdparty/lapack/dlabrd.c deleted file mode 100644 index 9f794fa..0000000 --- a/3rdparty/lapack/dlabrd.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlacpy.c b/3rdparty/lapack/dlacpy.c deleted file mode 100644 index 327ce8a..0000000 --- a/3rdparty/lapack/dlacpy.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlae2.c b/3rdparty/lapack/dlae2.c deleted file mode 100644 index 5d05abe..0000000 --- a/3rdparty/lapack/dlae2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaebz.c b/3rdparty/lapack/dlaebz.c deleted file mode 100644 index d5ebcc1..0000000 --- a/3rdparty/lapack/dlaebz.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed0.c b/3rdparty/lapack/dlaed0.c deleted file mode 100644 index a8fdc5a..0000000 --- a/3rdparty/lapack/dlaed0.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed1.c b/3rdparty/lapack/dlaed1.c deleted file mode 100644 index bf07869..0000000 --- a/3rdparty/lapack/dlaed1.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed2.c b/3rdparty/lapack/dlaed2.c deleted file mode 100644 index 7a61241..0000000 --- a/3rdparty/lapack/dlaed2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed3.c b/3rdparty/lapack/dlaed3.c deleted file mode 100644 index ea84c47..0000000 --- a/3rdparty/lapack/dlaed3.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed4.c b/3rdparty/lapack/dlaed4.c deleted file mode 100644 index 7054ad6..0000000 --- a/3rdparty/lapack/dlaed4.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed5.c b/3rdparty/lapack/dlaed5.c deleted file mode 100644 index a733acb..0000000 --- a/3rdparty/lapack/dlaed5.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed6.c b/3rdparty/lapack/dlaed6.c deleted file mode 100644 index 5cd51d9..0000000 --- a/3rdparty/lapack/dlaed6.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed7.c b/3rdparty/lapack/dlaed7.c deleted file mode 100644 index 5982de0..0000000 --- a/3rdparty/lapack/dlaed7.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed8.c b/3rdparty/lapack/dlaed8.c deleted file mode 100644 index 03ea90b..0000000 --- a/3rdparty/lapack/dlaed8.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaed9.c b/3rdparty/lapack/dlaed9.c deleted file mode 100644 index 48a1942..0000000 --- a/3rdparty/lapack/dlaed9.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaeda.c b/3rdparty/lapack/dlaeda.c deleted file mode 100644 index 8d94236..0000000 --- a/3rdparty/lapack/dlaeda.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaev2.c b/3rdparty/lapack/dlaev2.c deleted file mode 100644 index 61ab4ee..0000000 --- a/3rdparty/lapack/dlaev2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlagtf.c b/3rdparty/lapack/dlagtf.c deleted file mode 100644 index a278cef..0000000 --- a/3rdparty/lapack/dlagtf.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlagts.c b/3rdparty/lapack/dlagts.c deleted file mode 100644 index b7618b3..0000000 --- a/3rdparty/lapack/dlagts.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaisnan.c b/3rdparty/lapack/dlaisnan.c deleted file mode 100644 index 7ee1333..0000000 --- a/3rdparty/lapack/dlaisnan.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlals0.c b/3rdparty/lapack/dlals0.c deleted file mode 100644 index 4a8fd17..0000000 --- a/3rdparty/lapack/dlals0.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlalsa.c b/3rdparty/lapack/dlalsa.c deleted file mode 100644 index 7dceaea..0000000 --- a/3rdparty/lapack/dlalsa.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlalsd.c b/3rdparty/lapack/dlalsd.c deleted file mode 100644 index 43a746c..0000000 --- a/3rdparty/lapack/dlalsd.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlamch_custom.c b/3rdparty/lapack/dlamch_custom.c deleted file mode 100644 index 2f1584b..0000000 --- a/3rdparty/lapack/dlamch_custom.c +++ /dev/null @@ -1,58 +0,0 @@ -#include "clapack.h" -#include -#include - -/* *********************************************************************** */ - -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 -}; diff --git a/3rdparty/lapack/dlamrg.c b/3rdparty/lapack/dlamrg.c deleted file mode 100644 index f5e6760..0000000 --- a/3rdparty/lapack/dlamrg.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaneg.c b/3rdparty/lapack/dlaneg.c deleted file mode 100644 index a12d8fd..0000000 --- a/3rdparty/lapack/dlaneg.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlange.c b/3rdparty/lapack/dlange.c deleted file mode 100644 index 830a6c2..0000000 --- a/3rdparty/lapack/dlange.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlanst.c b/3rdparty/lapack/dlanst.c deleted file mode 100644 index 38be203..0000000 --- a/3rdparty/lapack/dlanst.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlansy.c b/3rdparty/lapack/dlansy.c deleted file mode 100644 index 6b8780f..0000000 --- a/3rdparty/lapack/dlansy.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlapy2.c b/3rdparty/lapack/dlapy2.c deleted file mode 100644 index b05b474..0000000 --- a/3rdparty/lapack/dlapy2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlar1v.c b/3rdparty/lapack/dlar1v.c deleted file mode 100644 index 0801489..0000000 --- a/3rdparty/lapack/dlar1v.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarf.c b/3rdparty/lapack/dlarf.c deleted file mode 100644 index d62cc42..0000000 --- a/3rdparty/lapack/dlarf.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarfb.c b/3rdparty/lapack/dlarfb.c deleted file mode 100644 index fa58ac3..0000000 --- a/3rdparty/lapack/dlarfb.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarfg.c b/3rdparty/lapack/dlarfg.c deleted file mode 100644 index 361b6f1..0000000 --- a/3rdparty/lapack/dlarfg.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarfp.c b/3rdparty/lapack/dlarfp.c deleted file mode 100644 index 1fdd7ef..0000000 --- a/3rdparty/lapack/dlarfp.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarft.c b/3rdparty/lapack/dlarft.c deleted file mode 100644 index 95ace4c..0000000 --- a/3rdparty/lapack/dlarft.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarnv.c b/3rdparty/lapack/dlarnv.c deleted file mode 100644 index 0d8bc66..0000000 --- a/3rdparty/lapack/dlarnv.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarra.c b/3rdparty/lapack/dlarra.c deleted file mode 100644 index eebc990..0000000 --- a/3rdparty/lapack/dlarra.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarrb.c b/3rdparty/lapack/dlarrb.c deleted file mode 100644 index a2851c7..0000000 --- a/3rdparty/lapack/dlarrb.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarrc.c b/3rdparty/lapack/dlarrc.c deleted file mode 100644 index abab4bc..0000000 --- a/3rdparty/lapack/dlarrc.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarrd.c b/3rdparty/lapack/dlarrd.c deleted file mode 100644 index 841f172..0000000 --- a/3rdparty/lapack/dlarrd.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarre.c b/3rdparty/lapack/dlarre.c deleted file mode 100644 index 25558b6..0000000 --- a/3rdparty/lapack/dlarre.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarrf.c b/3rdparty/lapack/dlarrf.c deleted file mode 100644 index e6b8fc5..0000000 --- a/3rdparty/lapack/dlarrf.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarrj.c b/3rdparty/lapack/dlarrj.c deleted file mode 100644 index 1220bc6..0000000 --- a/3rdparty/lapack/dlarrj.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarrk.c b/3rdparty/lapack/dlarrk.c deleted file mode 100644 index 355c5f2..0000000 --- a/3rdparty/lapack/dlarrk.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarrr.c b/3rdparty/lapack/dlarrr.c deleted file mode 100644 index d136f00..0000000 --- a/3rdparty/lapack/dlarrr.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlarrv.c b/3rdparty/lapack/dlarrv.c deleted file mode 100644 index bb0d336..0000000 --- a/3rdparty/lapack/dlarrv.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlartg_custom.c b/3rdparty/lapack/dlartg_custom.c deleted file mode 100644 index a0fdd2d..0000000 --- a/3rdparty/lapack/dlartg_custom.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaruv.c b/3rdparty/lapack/dlaruv.c deleted file mode 100644 index 007a1ad..0000000 --- a/3rdparty/lapack/dlaruv.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlas2.c b/3rdparty/lapack/dlas2.c deleted file mode 100644 index f2e1528..0000000 --- a/3rdparty/lapack/dlas2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlascl.c b/3rdparty/lapack/dlascl.c deleted file mode 100644 index a571cee..0000000 --- a/3rdparty/lapack/dlascl.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasd0.c b/3rdparty/lapack/dlasd0.c deleted file mode 100644 index 4d733b3..0000000 --- a/3rdparty/lapack/dlasd0.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasd1.c b/3rdparty/lapack/dlasd1.c deleted file mode 100644 index 9feedcb..0000000 --- a/3rdparty/lapack/dlasd1.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasd2.c b/3rdparty/lapack/dlasd2.c deleted file mode 100644 index 0b98cf3..0000000 --- a/3rdparty/lapack/dlasd2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasd3.c b/3rdparty/lapack/dlasd3.c deleted file mode 100644 index 4908be4..0000000 --- a/3rdparty/lapack/dlasd3.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasd4.c b/3rdparty/lapack/dlasd4.c deleted file mode 100644 index cf17371..0000000 --- a/3rdparty/lapack/dlasd4.c +++ /dev/null @@ -1,1010 +0,0 @@ -/* dlasd4.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 dlasd4_(integer *n, integer *i__, doublereal *d__, - doublereal *z__, doublereal *delta, doublereal *rho, doublereal * - sigma, doublereal *work, 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, dd[3]; - integer ii; - doublereal dw, zz[3]; - integer ip1; - doublereal eta, phi, eps, tau, psi; - integer iim1, iip1; - doublereal dphi, dpsi; - integer iter; - doublereal temp, prew, sg2lb, sg2ub, temp1, temp2, dtiim, delsq, dtiip; - integer niter; - doublereal dtisq; - logical swtch; - doublereal dtnsq; - extern /* Subroutine */ int dlaed6_(integer *, logical *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *) - , dlasd5_(integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); - doublereal delsq2, dtnsq1; - logical swtch3; - extern doublereal dlamch_(char *); - logical orgati; - doublereal erretm, dtipsq, rhoinv; - - -/* -- 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 updated */ -/* eigenvalue of a positive symmetric rank-one modification to */ -/* a positive diagonal matrix whose entries are given as the squares */ -/* of the corresponding entries in the array d, and that */ - -/* 0 <= 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 ) * 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, 0 <= 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 .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th */ -/* component. If N = 1, then DELTA(1) = 1. The vector DELTA */ -/* contains the information necessary to construct the */ -/* (singular) eigenvectors. */ - -/* RHO (input) DOUBLE PRECISION */ -/* The scalar in the symmetric updating formula. */ - -/* SIGMA (output) DOUBLE PRECISION */ -/* The computed sigma_I, the I-th updated eigenvalue. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension ( N ) */ -/* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th */ -/* component. If N = 1, then WORK( 1 ) = 1. */ - -/* 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 Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. 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 */ - --work; - --delta; - --z__; - --d__; - - /* Function Body */ - *info = 0; - if (*n == 1) { - -/* Presumably, I=1 upon entry */ - - *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]); - delta[1] = 1.; - work[1] = 1.; - return 0; - } - if (*n == 2) { - dlasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]); - 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 */ - - temp = *rho / 2.; - -/* If ||Z||_2 is not one, then TEMP should be set to */ -/* RHO * ||Z||_2^2 / TWO */ - - temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp)); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*n] + temp1; - delta[j] = d__[j] - d__[*n] - temp1; -/* L10: */ - } - - psi = 0.; - i__1 = *n - 2; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / (delta[j] * work[j]); -/* L20: */ - } - - c__ = rhoinv + psi; - w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[* - n] / (delta[*n] * work[*n]); - - if (w <= 0.) { - temp1 = sqrt(d__[*n] * d__[*n] + *rho); - temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[* - n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] * - z__[*n] / *rho; - -/* The following TAU is to approximate */ -/* SIGMA_n^2 - D( N )*D( N ) */ - - if (c__ <= temp) { - tau = *rho; - } else { - delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); - a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[* - n]; - b = z__[*n] * z__[*n] * delsq; - 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)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO */ - - } else { - delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); - a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; - b = z__[*n] * z__[*n] * delsq; - -/* The following TAU is to approximate */ -/* SIGMA_n^2 - D( N )*D( N ) */ - - 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)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 */ - - } - -/* The following ETA is to approximate SIGMA_n - D( N ) */ - - eta = tau / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau)); - - *sigma = d__[*n] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - eta; - work[j] = d__[j] + d__[*i__] + eta; -/* 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] * work[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] * work[*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) { - goto L240; - } - -/* Calculate the new step */ - - ++niter; - dtnsq1 = work[*n - 1] * delta[*n - 1]; - dtnsq = work[*n] * delta[*n]; - c__ = w - dtnsq1 * dpsi - dtnsq * dphi; - a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi); - b = dtnsq * dtnsq1 * w; - if (c__ < 0.) { - c__ = abs(c__); - } - if (c__ == 0.) { - eta = *rho - *sigma * *sigma; - } 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 = eta - dtnsq; - if (temp > *rho) { - eta = *rho + dtnsq; - } - - tau += eta; - eta /= *sigma + sqrt(eta + *sigma * *sigma); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; - work[j] += eta; -/* L50: */ - } - - *sigma += 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] / (work[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] / (work[*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 <= 20; ++niter) { - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - goto L240; - } - -/* Calculate the new step */ - - dtnsq1 = work[*n - 1] * delta[*n - 1]; - dtnsq = work[*n] * delta[*n]; - c__ = w - dtnsq1 * dpsi - dtnsq * dphi; - a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi); - b = dtnsq1 * dtnsq * 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 = eta - dtnsq; - if (temp <= 0.) { - eta /= 2.; - } - - tau += eta; - eta /= *sigma + sqrt(eta + *sigma * *sigma); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; - work[j] += eta; -/* L70: */ - } - - *sigma += 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] / (work[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] / (work[*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; - goto L240; - -/* End for the case I = N */ - - } else { - -/* The case for I < N */ - - niter = 1; - ip1 = *i__ + 1; - -/* Calculate initial guess */ - - delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]); - delsq2 = delsq / 2.; - temp = delsq2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + delsq2)); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*i__] + temp; - delta[j] = d__[j] - d__[*i__] - temp; -/* L100: */ - } - - psi = 0.; - i__1 = *i__ - 1; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / (work[j] * delta[j]); -/* L110: */ - } - - phi = 0.; - i__1 = *i__ + 2; - for (j = *n; j >= i__1; --j) { - phi += z__[j] * z__[j] / (work[j] * delta[j]); -/* L120: */ - } - c__ = rhoinv + psi + phi; - w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[ - ip1] * z__[ip1] / (work[ip1] * delta[ip1]); - - if (w > 0.) { - -/* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 */ - -/* We choose d(i) as origin. */ - - orgati = TRUE_; - sg2lb = 0.; - sg2ub = delsq2; - a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; - b = z__[*i__] * z__[*i__] * delsq; - 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.); - } - -/* TAU now is an estimation of SIGMA^2 - D( I )^2. The */ -/* following, however, is the corresponding estimation of */ -/* SIGMA - D( I ). */ - - eta = tau / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau)); - } else { - -/* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 */ - -/* We choose d(i+1) as origin. */ - - orgati = FALSE_; - sg2lb = -delsq2; - sg2ub = 0.; - a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; - b = z__[ip1] * z__[ip1] * delsq; - 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.); - } - -/* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The */ -/* following, however, is the corresponding estimation of */ -/* SIGMA - D( IP1 ). */ - - eta = tau / (d__[ip1] + sqrt((d__1 = d__[ip1] * d__[ip1] + tau, - abs(d__1)))); - } - - if (orgati) { - ii = *i__; - *sigma = d__[*i__] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*i__] + eta; - delta[j] = d__[j] - d__[*i__] - eta; -/* L130: */ - } - } else { - ii = *i__ + 1; - *sigma = d__[ip1] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[ip1] + eta; - delta[j] = d__[j] - d__[ip1] - eta; -/* L140: */ - } - } - 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] / (work[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] / (work[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] / (work[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) { - goto L240; - } - - if (w <= 0.) { - sg2lb = max(sg2lb,tau); - } else { - sg2ub = min(sg2ub,tau); - } - -/* Calculate the new step */ - - ++niter; - if (! swtch3) { - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (orgati) { -/* Computing 2nd power */ - d__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (d__1 * d__1); - } else { -/* Computing 2nd power */ - d__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (d__1 * d__1); - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.) { - if (a == 0.) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + - dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * (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 */ - - dtiim = work[iim1] * delta[iim1]; - dtiip = work[iip1] * delta[iip1]; - temp = rhoinv + psi + phi; - if (orgati) { - temp1 = z__[iim1] / dtiim; - temp1 *= temp1; - c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * - (d__[iim1] + d__[iip1]) * temp1; - zz[0] = z__[iim1] * z__[iim1]; - if (dpsi < temp1) { - zz[2] = dtiip * dtiip * dphi; - } else { - zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); - } - } else { - temp1 = z__[iip1] / dtiip; - temp1 *= temp1; - c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * - (d__[iim1] + d__[iip1]) * temp1; - if (dphi < temp1) { - zz[0] = dtiim * dtiim * dpsi; - } else { - zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); - } - zz[2] = z__[iip1] * z__[iip1]; - } - zz[1] = z__[ii] * z__[ii]; - dd[0] = dtiim; - dd[1] = delta[ii] * work[ii]; - dd[2] = dtiip; - dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); - if (*info != 0) { - goto L240; - } - } - -/* 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; - } - if (orgati) { - temp1 = work[*i__] * delta[*i__]; - temp = eta - temp1; - } else { - temp1 = work[ip1] * delta[ip1]; - temp = eta - temp1; - } - if (temp > sg2ub || temp < sg2lb) { - if (w < 0.) { - eta = (sg2ub - tau) / 2.; - } else { - eta = (sg2lb - tau) / 2.; - } - } - - tau += eta; - eta /= *sigma + sqrt(*sigma * *sigma + eta); - - prew = w; - - *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += eta; - delta[j] -= eta; -/* L170: */ - } - -/* 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] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L180: */ - } - 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] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L190: */ - } - - temp = z__[ii] / (work[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 <= 0.) { - sg2lb = max(sg2lb,tau); - } else { - sg2ub = min(sg2ub,tau); - } - - swtch = FALSE_; - if (orgati) { - if (-w > abs(prew) / 10.) { - swtch = TRUE_; - } - } else { - if (w > abs(prew) / 10.) { - swtch = TRUE_; - } - } - -/* Main loop to update the values of the array DELTA and WORK */ - - iter = niter + 1; - - for (niter = iter; niter <= 20; ++niter) { - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - goto L240; - } - -/* Calculate the new step */ - - if (! swtch3) { - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (! swtch) { - if (orgati) { -/* Computing 2nd power */ - d__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (d__1 * d__1); - } else { -/* Computing 2nd power */ - d__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (d__1 * d__1); - } - } else { - temp = z__[ii] / (work[ii] * delta[ii]); - if (orgati) { - dpsi += temp * temp; - } else { - dphi += temp * temp; - } - c__ = w - dtisq * dpsi - dtipsq * dphi; - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.) { - if (a == 0.) { - if (! swtch) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * - (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * ( - dpsi + dphi); - } - } else { - a = dtisq * dtisq * dpsi + dtipsq * dtipsq * 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 */ - - dtiim = work[iim1] * delta[iim1]; - dtiip = work[iip1] * delta[iip1]; - temp = rhoinv + psi + phi; - if (swtch) { - c__ = temp - dtiim * dpsi - dtiip * dphi; - zz[0] = dtiim * dtiim * dpsi; - zz[2] = dtiip * dtiip * dphi; - } else { - if (orgati) { - temp1 = z__[iim1] / dtiim; - temp1 *= temp1; - temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[ - iip1]) * temp1; - c__ = temp - dtiip * (dpsi + dphi) - temp2; - zz[0] = z__[iim1] * z__[iim1]; - if (dpsi < temp1) { - zz[2] = dtiip * dtiip * dphi; - } else { - zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); - } - } else { - temp1 = z__[iip1] / dtiip; - temp1 *= temp1; - temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[ - iip1]) * temp1; - c__ = temp - dtiim * (dpsi + dphi) - temp2; - if (dphi < temp1) { - zz[0] = dtiim * dtiim * dpsi; - } else { - zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); - } - zz[2] = z__[iip1] * z__[iip1]; - } - } - dd[0] = dtiim; - dd[1] = delta[ii] * work[ii]; - dd[2] = dtiip; - dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); - if (*info != 0) { - goto L240; - } - } - -/* 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; - } - if (orgati) { - temp1 = work[*i__] * delta[*i__]; - temp = eta - temp1; - } else { - temp1 = work[ip1] * delta[ip1]; - temp = eta - temp1; - } - if (temp > sg2ub || temp < sg2lb) { - if (w < 0.) { - eta = (sg2ub - tau) / 2.; - } else { - eta = (sg2lb - tau) / 2.; - } - } - - tau += eta; - eta /= *sigma + sqrt(*sigma * *sigma + eta); - - *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += eta; - delta[j] -= eta; -/* L200: */ - } - - 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] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L210: */ - } - 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] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L220: */ - } - - temp = z__[ii] / (work[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; - } - - if (w <= 0.) { - sg2lb = max(sg2lb,tau); - } else { - sg2ub = min(sg2ub,tau); - } - -/* L230: */ - } - -/* Return with INFO = 1, NITER = MAXIT and not converged */ - - *info = 1; - - } - -L240: - return 0; - -/* End of DLASD4 */ - -} /* dlasd4_ */ diff --git a/3rdparty/lapack/dlasd5.c b/3rdparty/lapack/dlasd5.c deleted file mode 100644 index d5c801d..0000000 --- a/3rdparty/lapack/dlasd5.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasd6.c b/3rdparty/lapack/dlasd6.c deleted file mode 100644 index 5306f4a..0000000 --- a/3rdparty/lapack/dlasd6.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasd7.c b/3rdparty/lapack/dlasd7.c deleted file mode 100644 index cee3688..0000000 --- a/3rdparty/lapack/dlasd7.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasd8.c b/3rdparty/lapack/dlasd8.c deleted file mode 100644 index 731e334..0000000 --- a/3rdparty/lapack/dlasd8.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasda.c b/3rdparty/lapack/dlasda.c deleted file mode 100644 index dc604f8..0000000 --- a/3rdparty/lapack/dlasda.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasdq.c b/3rdparty/lapack/dlasdq.c deleted file mode 100644 index a45e994..0000000 --- a/3rdparty/lapack/dlasdq.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasdt.c b/3rdparty/lapack/dlasdt.c deleted file mode 100644 index a63bb70..0000000 --- a/3rdparty/lapack/dlasdt.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlaset.c b/3rdparty/lapack/dlaset.c deleted file mode 100644 index 2547258..0000000 --- a/3rdparty/lapack/dlaset.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasq1.c b/3rdparty/lapack/dlasq1.c deleted file mode 100644 index a14d0fa..0000000 --- a/3rdparty/lapack/dlasq1.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasq2.c b/3rdparty/lapack/dlasq2.c deleted file mode 100644 index 5359cbe..0000000 --- a/3rdparty/lapack/dlasq2.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasq3.c b/3rdparty/lapack/dlasq3.c deleted file mode 100644 index 1227c50..0000000 --- a/3rdparty/lapack/dlasq3.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasq4.c b/3rdparty/lapack/dlasq4.c deleted file mode 100644 index 8d9020b..0000000 --- a/3rdparty/lapack/dlasq4.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasq5.c b/3rdparty/lapack/dlasq5.c deleted file mode 100644 index 1439891..0000000 --- a/3rdparty/lapack/dlasq5.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasq6.c b/3rdparty/lapack/dlasq6.c deleted file mode 100644 index d34eb3b..0000000 --- a/3rdparty/lapack/dlasq6.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasr_custom.c b/3rdparty/lapack/dlasr_custom.c deleted file mode 100644 index 92aa27a..0000000 --- a/3rdparty/lapack/dlasr_custom.c +++ /dev/null @@ -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_ */ diff --git a/3rdparty/lapack/dlasrt.c b/3rdparty/lapack/dlasrt.c deleted file mode 100644 index 9b41492..0000000 --- a/3rdparty/lapack/dlasrt.c +++ /dev/null @@ -1,286 +0,0 @@ -/* dlasrt.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 dlasrt_(char *id, integer *n, doublereal *d__, integer * - info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j; - doublereal d1, d2, d3; - integer dir; - doublereal tmp; - integer endd; - extern logical lsame_(char *, char *); - integer stack[64] /* was [2][32] */; - doublereal dmnmx; - integer start; - extern /* Subroutine */ int xerbla_(char *, integer *); - integer stkpnt; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Sort the numbers in D in increasing order (if ID = 'I') or */ -/* in decreasing order (if ID = 'D' ). */ - -/* Use Quick Sort, reverting to Insertion sort on arrays of */ -/* size <= 20. Dimension of STACK limits N to about 2**32. */ - -/* Arguments */ -/* ========= */ - -/* ID (input) CHARACTER*1 */ -/* = 'I': sort D in increasing order; */ -/* = 'D': sort D in decreasing order. */ - -/* N (input) INTEGER */ -/* The length of the array D. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the array to be sorted. */ -/* On exit, D has been sorted into increasing order */ -/* (D(1) <= ... <= D(N) ) or into decreasing order */ -/* (D(1) >= ... >= D(N) ), depending on ID. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input paramters. */ - - /* Parameter adjustments */ - --d__; - - /* Function Body */ - *info = 0; - dir = -1; - if (lsame_(id, "D")) { - dir = 0; - } else if (lsame_(id, "I")) { - dir = 1; - } - if (dir == -1) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASRT", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 1) { - return 0; - } - - stkpnt = 1; - stack[0] = 1; - stack[1] = *n; -L10: - start = stack[(stkpnt << 1) - 2]; - endd = stack[(stkpnt << 1) - 1]; - --stkpnt; - if (endd - start <= 20 && endd - start > 0) { - -/* Do Insertion sort on D( START:ENDD ) */ - - if (dir == 0) { - -/* Sort into decreasing order */ - - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] > d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L30; - } -/* L20: */ - } -L30: - ; - } - - } else { - -/* Sort into increasing order */ - - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] < d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L50; - } -/* L40: */ - } -L50: - ; - } - - } - - } else if (endd - start > 20) { - -/* Partition D( START:ENDD ) and stack parts, largest one first */ - -/* Choose partition entry as median of 3 */ - - d1 = d__[start]; - d2 = d__[endd]; - i__ = (start + endd) / 2; - d3 = d__[i__]; - if (d1 < d2) { - if (d3 < d1) { - dmnmx = d1; - } else if (d3 < d2) { - dmnmx = d3; - } else { - dmnmx = d2; - } - } else { - if (d3 < d2) { - dmnmx = d2; - } else if (d3 < d1) { - dmnmx = d3; - } else { - dmnmx = d1; - } - } - - if (dir == 0) { - -/* Sort into decreasing order */ - - i__ = start - 1; - j = endd + 1; -L60: -L70: - --j; - if (d__[j] < dmnmx) { - goto L70; - } -L80: - ++i__; - if (d__[i__] > dmnmx) { - goto L80; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L60; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - } else { - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - } - } else { - -/* Sort into increasing order */ - - i__ = start - 1; - j = endd + 1; -L90: -L100: - --j; - if (d__[j] > dmnmx) { - goto L100; - } -L110: - ++i__; - if (d__[i__] < dmnmx) { - goto L110; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L90; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - } else { - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - } - } - } - if (stkpnt > 0) { - goto L10; - } - return 0; - -/* End of DLASRT */ - -} /* dlasrt_ */ diff --git a/3rdparty/lapack/dlassq.c b/3rdparty/lapack/dlassq.c deleted file mode 100644 index 8776435..0000000 --- a/3rdparty/lapack/dlassq.c +++ /dev/null @@ -1,116 +0,0 @@ -/* dlassq.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 dlassq_(integer *n, doublereal *x, integer *incx, - doublereal *scale, doublereal *sumsq) -{ - /* System generated locals */ - integer i__1, i__2; - doublereal d__1; - - /* Local variables */ - integer ix; - doublereal absxi; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASSQ returns the values scl and smsq such that */ - -/* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */ - -/* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */ -/* assumed to be non-negative and scl returns the value */ - -/* scl = max( scale, abs( x( i ) ) ). */ - -/* scale and sumsq must be supplied in SCALE and SUMSQ and */ -/* scl and smsq are overwritten on SCALE and SUMSQ respectively. */ - -/* The routine makes only one pass through the vector x. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of elements to be used from the vector X. */ - -/* X (input) DOUBLE PRECISION array, dimension (N) */ -/* The vector for which a scaled sum of squares is computed. */ -/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */ - -/* INCX (input) INTEGER */ -/* The increment between successive values of the vector X. */ -/* INCX > 0. */ - -/* SCALE (input/output) DOUBLE PRECISION */ -/* On entry, the value scale in the equation above. */ -/* On exit, SCALE is overwritten with scl , the scaling factor */ -/* for the sum of squares. */ - -/* SUMSQ (input/output) DOUBLE PRECISION */ -/* On entry, the value sumsq in the equation above. */ -/* On exit, SUMSQ is overwritten with smsq , the basic sum of */ -/* squares from which scl has been factored out. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n > 0) { - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.) { - absxi = (d__1 = x[ix], abs(d__1)); - if (*scale < absxi) { -/* Computing 2nd power */ - d__1 = *scale / absxi; - *sumsq = *sumsq * (d__1 * d__1) + 1; - *scale = absxi; - } else { -/* Computing 2nd power */ - d__1 = absxi / *scale; - *sumsq += d__1 * d__1; - } - } -/* L10: */ - } - } - return 0; - -/* End of DLASSQ */ - -} /* dlassq_ */ diff --git a/3rdparty/lapack/dlasv2.c b/3rdparty/lapack/dlasv2.c deleted file mode 100644 index 97263c5..0000000 --- a/3rdparty/lapack/dlasv2.c +++ /dev/null @@ -1,274 +0,0 @@ -/* dlasv2.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 = 2.; -static doublereal c_b4 = 1.; - -/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal * - csr, doublereal *snl, doublereal *csl) -{ - /* System generated locals */ - doublereal d__1; - - /* Builtin functions */ - double sqrt(doublereal), d_sign(doublereal *, doublereal *); - - /* Local variables */ - doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, - crt, slt, srt; - integer pmax; - doublereal temp; - logical swap; - doublereal tsign; - extern doublereal dlamch_(char *); - logical gasmal; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASV2 computes the singular value decomposition of a 2-by-2 */ -/* triangular matrix */ -/* [ F G ] */ -/* [ 0 H ]. */ -/* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */ -/* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */ -/* right singular vectors for abs(SSMAX), giving the decomposition */ - -/* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */ -/* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */ - -/* 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 */ -/* abs(SSMIN) is the smaller singular value. */ - -/* SSMAX (output) DOUBLE PRECISION */ -/* abs(SSMAX) is the larger singular value. */ - -/* SNL (output) DOUBLE PRECISION */ -/* CSL (output) DOUBLE PRECISION */ -/* The vector (CSL, SNL) is a unit left singular vector for the */ -/* singular value abs(SSMAX). */ - -/* SNR (output) DOUBLE PRECISION */ -/* CSR (output) DOUBLE PRECISION */ -/* The vector (CSR, SNR) is a unit right singular vector for the */ -/* singular value abs(SSMAX). */ - -/* Further Details */ -/* =============== */ - -/* Any input parameter may be aliased with any output parameter. */ - -/* Barring over/underflow and assuming a guard digit in subtraction, all */ -/* output quantities are correct to within a few units in the last */ -/* place (ulps). */ - -/* 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 .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - ft = *f; - fa = abs(ft); - ht = *h__; - ha = abs(*h__); - -/* PMAX points to the maximum absolute element of matrix */ -/* PMAX = 1 if F largest in absolute values */ -/* PMAX = 2 if G largest in absolute values */ -/* PMAX = 3 if H largest in absolute values */ - - pmax = 1; - swap = ha > fa; - if (swap) { - pmax = 3; - temp = ft; - ft = ht; - ht = temp; - temp = fa; - fa = ha; - ha = temp; - -/* Now FA .ge. HA */ - - } - gt = *g; - ga = abs(gt); - if (ga == 0.) { - -/* Diagonal matrix */ - - *ssmin = ha; - *ssmax = fa; - clt = 1.; - crt = 1.; - slt = 0.; - srt = 0.; - } else { - gasmal = TRUE_; - if (ga > fa) { - pmax = 2; - if (fa / ga < dlamch_("EPS")) { - -/* Case of very large GA */ - - gasmal = FALSE_; - *ssmax = ga; - if (ha > 1.) { - *ssmin = fa / (ga / ha); - } else { - *ssmin = fa / ga * ha; - } - clt = 1.; - slt = ht / gt; - srt = 1.; - crt = ft / gt; - } - } - if (gasmal) { - -/* Normal case */ - - d__ = fa - ha; - if (d__ == fa) { - -/* Copes with infinite F or H */ - - l = 1.; - } else { - l = d__ / fa; - } - -/* Note that 0 .le. L .le. 1 */ - - m = gt / ft; - -/* Note that abs(M) .le. 1/macheps */ - - t = 2. - l; - -/* Note that T .ge. 1 */ - - mm = m * m; - tt = t * t; - s = sqrt(tt + mm); - -/* Note that 1 .le. S .le. 1 + 1/macheps */ - - if (l == 0.) { - r__ = abs(m); - } else { - r__ = sqrt(l * l + mm); - } - -/* Note that 0 .le. R .le. 1 + 1/macheps */ - - a = (s + r__) * .5; - -/* Note that 1 .le. A .le. 1 + abs(M) */ - - *ssmin = ha / a; - *ssmax = fa * a; - if (mm == 0.) { - -/* Note that M is very tiny */ - - if (l == 0.) { - t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >); - } else { - t = gt / d_sign(&d__, &ft) + m / t; - } - } else { - t = (m / (s + t) + m / (r__ + l)) * (a + 1.); - } - l = sqrt(t * t + 4.); - crt = 2. / l; - srt = t / l; - clt = (crt + srt * m) / a; - slt = ht / ft * srt / a; - } - } - if (swap) { - *csl = srt; - *snl = crt; - *csr = slt; - *snr = clt; - } else { - *csl = clt; - *snl = slt; - *csr = crt; - *snr = srt; - } - -/* Correct signs of SSMAX and SSMIN */ - - if (pmax == 1) { - tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f); - } - if (pmax == 2) { - tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g); - } - if (pmax == 3) { - tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__); - } - *ssmax = d_sign(ssmax, &tsign); - d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__); - *ssmin = d_sign(ssmin, &d__1); - return 0; - -/* End of DLASV2 */ - -} /* dlasv2_ */ diff --git a/3rdparty/lapack/dlaswp.c b/3rdparty/lapack/dlaswp.c deleted file mode 100644 index 43ed0d5..0000000 --- a/3rdparty/lapack/dlaswp.c +++ /dev/null @@ -1,158 +0,0 @@ -/* dlaswp.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 dlaswp_(integer *n, doublereal *a, integer *lda, integer - *k1, integer *k2, integer *ipiv, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; - doublereal temp; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASWP performs a series of row interchanges on the matrix A. */ -/* One row interchange is initiated for each of rows K1 through K2 of A. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the matrix of column dimension N to which the row */ -/* interchanges will be applied. */ -/* On exit, the permuted matrix. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ - -/* K1 (input) INTEGER */ -/* The first element of IPIV for which a row interchange will */ -/* be done. */ - -/* K2 (input) INTEGER */ -/* The last element of IPIV for which a row interchange will */ -/* be done. */ - -/* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) */ -/* The vector of pivot indices. Only the elements in positions */ -/* K1 through K2 of IPIV are accessed. */ -/* IPIV(K) = L implies rows K and L are to be interchanged. */ - -/* INCX (input) INTEGER */ -/* The increment between successive values of IPIV. If IPIV */ -/* is negative, the pivots are applied in reverse order. */ - -/* Further Details */ -/* =============== */ - -/* Modified by */ -/* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Interchange row I with row IPIV(I) for each of rows K1 through K2. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - - /* Function Body */ - if (*incx > 0) { - ix0 = *k1; - i1 = *k1; - i2 = *k2; - inc = 1; - } else if (*incx < 0) { - ix0 = (1 - *k2) * *incx + 1; - i1 = *k2; - i2 = *k1; - inc = -1; - } else { - return 0; - } - - n32 = *n / 32 << 5; - if (n32 != 0) { - i__1 = n32; - for (j = 1; j <= i__1; j += 32) { - ix = ix0; - i__2 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) - { - ip = ipiv[ix]; - if (ip != i__) { - i__4 = j + 31; - for (k = j; k <= i__4; ++k) { - temp = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = a[ip + k * a_dim1]; - a[ip + k * a_dim1] = temp; -/* L10: */ - } - } - ix += *incx; -/* L20: */ - } -/* L30: */ - } - } - if (n32 != *n) { - ++n32; - ix = ix0; - i__1 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { - ip = ipiv[ix]; - if (ip != i__) { - i__2 = *n; - for (k = n32; k <= i__2; ++k) { - temp = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = a[ip + k * a_dim1]; - a[ip + k * a_dim1] = temp; -/* L40: */ - } - } - ix += *incx; -/* L50: */ - } - } - - return 0; - -/* End of DLASWP */ - -} /* dlaswp_ */ diff --git a/3rdparty/lapack/dlasyf.c b/3rdparty/lapack/dlasyf.c deleted file mode 100644 index 65be9c3..0000000 --- a/3rdparty/lapack/dlasyf.c +++ /dev/null @@ -1,721 +0,0 @@ -/* dlasyf.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.; -static doublereal c_b9 = 1.; - -/* Subroutine */ int dlasyf_(char *uplo, integer *n, integer *nb, integer *kb, - doublereal *a, integer *lda, integer *ipiv, doublereal *w, integer * - ldw, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer j, k; - doublereal t, r1, d11, d21, d22; - integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax; - doublereal alpha; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dgemm_(char *, char *, integer *, integer *, integer * -, doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *), dcopy_(integer *, - doublereal *, integer *, doublereal *, integer *), dswap_(integer - *, doublereal *, integer *, doublereal *, integer *); - integer kstep; - doublereal absakk; - extern integer idamax_(integer *, doublereal *, integer *); - doublereal colmax, rowmax; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASYF computes a partial factorization of a real symmetric matrix A */ -/* using the Bunch-Kaufman diagonal pivoting method. The partial */ -/* factorization has the form: */ - -/* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ -/* ( 0 U22 ) ( 0 D ) ( U12' U22' ) */ - -/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L' */ -/* ( L21 I ) ( 0 A22 ) ( 0 I ) */ - -/* where the order of D is at most NB. The actual order is returned in */ -/* the argument KB, and is either NB or NB-1, or N if N <= NB. */ - -/* DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code */ -/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */ -/* A22 (if UPLO = 'L'). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NB (input) INTEGER */ -/* The maximum number of columns of the matrix A that should be */ -/* factored. NB should be at least 2 to allow for 2-by-2 pivot */ -/* blocks. */ - -/* KB (output) INTEGER */ -/* The number of columns of A that were actually factored. */ -/* KB is either NB-1 or NB, or N if N <= NB. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit, A contains details of the partial factorization. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D. */ -/* If UPLO = 'U', only the last KB elements of IPIV are set; */ -/* if UPLO = 'L', only the first KB elements are set. */ - -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB) */ - -/* LDW (input) INTEGER */ -/* The leading dimension of the array W. LDW >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - w_dim1 = *ldw; - w_offset = 1 + w_dim1; - w -= w_offset; - - /* Function Body */ - *info = 0; - -/* Initialize ALPHA for use in choosing pivot block size. */ - - alpha = (sqrt(17.) + 1.) / 8.; - - if (lsame_(uplo, "U")) { - -/* Factorize the trailing columns of A using the upper triangle */ -/* of A and working backwards, and compute the matrix W = U12*D */ -/* for use in updating A11 */ - -/* K is the main loop index, decreasing from N in steps of 1 or 2 */ - -/* KW is the column of W which corresponds to column K of A */ - - k = *n; -L10: - kw = *nb + k - *n; - -/* Exit from loop */ - - if (k <= *n - *nb + 1 && *nb < *n || k < 1) { - goto L30; - } - -/* Copy column K of A to column KW of W and update it */ - - dcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); - if (k < *n) { - i__1 = *n - k; - dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1], - lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw * - w_dim1 + 1], &c__1); - } - - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = w[k + kw * w_dim1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k > 1) { - i__1 = k - 1; - imax = idamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); - colmax = (d__1 = w[imax + kw * w_dim1], abs(d__1)); - } else { - colmax = 0.; - } - - if (max(absakk,colmax) == 0.) { - -/* Column K is zero: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* Copy column IMAX to column KW-1 of W and update it */ - - dcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * - w_dim1 + 1], &c__1); - i__1 = k - imax; - dcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + - 1 + (kw - 1) * w_dim1], &c__1); - if (k < *n) { - i__1 = *n - k; - dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * - a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], - ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1); - } - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - i__1 = k - imax; - jmax = imax + idamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], - &c__1); - rowmax = (d__1 = w[jmax + (kw - 1) * w_dim1], abs(d__1)); - if (imax > 1) { - i__1 = imax - 1; - jmax = idamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = w[jmax + (kw - 1) * w_dim1], - abs(d__1)); - rowmax = max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = w[imax + (kw - 1) * w_dim1], abs(d__1)) >= - alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - -/* copy column KW-1 of W to column KW */ - - dcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * - w_dim1 + 1], &c__1); - } else { - -/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k - kstep + 1; - kkw = *nb + kk - *n; - -/* Updated column KP is already stored in column KKW of W */ - - if (kp != kk) { - -/* Copy non-updated column KK to column KP */ - - a[kp + k * a_dim1] = a[kk + k * a_dim1]; - i__1 = k - 1 - kp; - dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + - 1) * a_dim1], lda); - dcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & - c__1); - -/* Interchange rows KK and KP in last KK columns of A and W */ - - i__1 = *n - kk + 1; - dswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], - lda); - i__1 = *n - kk + 1; - dswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * - w_dim1], ldw); - } - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column KW of W now holds */ - -/* W(k) = U(k)*D(k) */ - -/* where U(k) is the k-th column of U */ - -/* Store U(k) in column k of A */ - - dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & - c__1); - r1 = 1. / a[k + k * a_dim1]; - i__1 = k - 1; - dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); - } else { - -/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ -/* hold */ - -/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ - -/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ -/* of U */ - - if (k > 2) { - -/* Store U(k) and U(k-1) in columns k and k-1 of A */ - - d21 = w[k - 1 + kw * w_dim1]; - d11 = w[k + kw * w_dim1] / d21; - d22 = w[k - 1 + (kw - 1) * w_dim1] / d21; - t = 1. / (d11 * d22 - 1.); - d21 = t / d21; - i__1 = k - 2; - for (j = 1; j <= i__1; ++j) { - a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1) - * w_dim1] - w[j + kw * w_dim1]); - a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] - - w[j + (kw - 1) * w_dim1]); -/* L20: */ - } - } - -/* Copy D(k) to A */ - - a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; - a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; - a[k + k * a_dim1] = w[k + kw * w_dim1]; - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k - 1] = -kp; - } - -/* Decrease K and return to the start of the main loop */ - - k -= kstep; - goto L10; - -L30: - -/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ - -/* A11 := A11 - U12*D*U12' = A11 - U12*W' */ - -/* computing blocks of NB columns at a time */ - - i__1 = -(*nb); - for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += - i__1) { -/* Computing MIN */ - i__2 = *nb, i__3 = k - j + 1; - jb = min(i__2,i__3); - -/* Update the upper triangle of the diagonal block */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = jj - j + 1; - i__4 = *n - k; - dgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) * - a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9, - &a[j + jj * a_dim1], &c__1); -/* L40: */ - } - -/* Update the rectangular superdiagonal block */ - - i__2 = j - 1; - i__3 = *n - k; - dgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[( - k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, - &c_b9, &a[j * a_dim1 + 1], lda); -/* L50: */ - } - -/* Put U12 in standard form by partially undoing the interchanges */ -/* in columns k+1:n */ - - j = k + 1; -L60: - jj = j; - jp = ipiv[j]; - if (jp < 0) { - jp = -jp; - ++j; - } - ++j; - if (jp != jj && j <= *n) { - i__1 = *n - j + 1; - dswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); - } - if (j <= *n) { - goto L60; - } - -/* Set KB to the number of columns factorized */ - - *kb = *n - k; - - } else { - -/* Factorize the leading columns of A using the lower triangle */ -/* of A and working forwards, and compute the matrix W = L21*D */ -/* for use in updating A22 */ - -/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ - - k = 1; -L70: - -/* Exit from loop */ - - if (k >= *nb && *nb < *n || k > *n) { - goto L90; - } - -/* Copy column K of A to column K of W and update it */ - - i__1 = *n - k + 1; - dcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); - i__1 = *n - k + 1; - i__2 = k - 1; - dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k - + w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1); - - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = w[k + k * w_dim1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k < *n) { - i__1 = *n - k; - imax = k + idamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); - colmax = (d__1 = w[imax + k * w_dim1], abs(d__1)); - } else { - colmax = 0.; - } - - if (max(absakk,colmax) == 0.) { - -/* Column K is zero: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* Copy column IMAX to column K+1 of W and update it */ - - i__1 = imax - k; - dcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * - w_dim1], &c__1); - i__1 = *n - imax + 1; - dcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + - 1) * w_dim1], &c__1); - i__1 = *n - k + 1; - i__2 = k - 1; - dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], - lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) * - w_dim1], &c__1); - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - i__1 = imax - k; - jmax = k - 1 + idamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) - ; - rowmax = (d__1 = w[jmax + (k + 1) * w_dim1], abs(d__1)); - if (imax < *n) { - i__1 = *n - imax; - jmax = imax + idamax_(&i__1, &w[imax + 1 + (k + 1) * - w_dim1], &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = w[jmax + (k + 1) * w_dim1], - abs(d__1)); - rowmax = max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = w[imax + (k + 1) * w_dim1], abs(d__1)) >= - alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - -/* copy column K+1 of W to column K */ - - i__1 = *n - k + 1; - dcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * - w_dim1], &c__1); - } else { - -/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k + kstep - 1; - -/* Updated column KP is already stored in column KK of W */ - - if (kp != kk) { - -/* Copy non-updated column KK to column KP */ - - a[kp + k * a_dim1] = a[kk + k * a_dim1]; - i__1 = kp - k - 1; - dcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) - * a_dim1], lda); - i__1 = *n - kp + 1; - dcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * - a_dim1], &c__1); - -/* Interchange rows KK and KP in first KK columns of A and W */ - - dswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); - dswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); - } - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column k of W now holds */ - -/* W(k) = L(k)*D(k) */ - -/* where L(k) is the k-th column of L */ - -/* Store L(k) in column k of A */ - - i__1 = *n - k + 1; - dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & - c__1); - if (k < *n) { - r1 = 1. / a[k + k * a_dim1]; - i__1 = *n - k; - dscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); - } - } else { - -/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ - -/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ - -/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ -/* of L */ - - if (k < *n - 1) { - -/* Store L(k) and L(k+1) in columns k and k+1 of A */ - - d21 = w[k + 1 + k * w_dim1]; - d11 = w[k + 1 + (k + 1) * w_dim1] / d21; - d22 = w[k + k * w_dim1] / d21; - t = 1. / (d11 * d22 - 1.); - d21 = t / d21; - i__1 = *n; - for (j = k + 2; j <= i__1; ++j) { - a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] - - w[j + (k + 1) * w_dim1]); - a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) * - w_dim1] - w[j + k * w_dim1]); -/* L80: */ - } - } - -/* Copy D(k) to A */ - - a[k + k * a_dim1] = w[k + k * w_dim1]; - a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; - a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k + 1] = -kp; - } - -/* Increase K and return to the start of the main loop */ - - k += kstep; - goto L70; - -L90: - -/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ - -/* A22 := A22 - L21*D*L21' = A22 - L21*W' */ - -/* computing blocks of NB columns at a time */ - - i__1 = *n; - i__2 = *nb; - for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - -/* Update the lower triangle of the diagonal block */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - i__4 = j + jb - jj; - i__5 = k - 1; - dgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1], - lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1] -, &c__1); -/* L100: */ - } - -/* Update the rectangular subdiagonal block */ - - if (j + jb <= *n) { - i__3 = *n - j - jb + 1; - i__4 = k - 1; - dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8, - &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9, - &a[j + jb + j * a_dim1], lda); - } -/* L110: */ - } - -/* Put L21 in standard form by partially undoing the interchanges */ -/* in columns 1:k-1 */ - - j = k - 1; -L120: - jj = j; - jp = ipiv[j]; - if (jp < 0) { - jp = -jp; - --j; - } - --j; - if (jp != jj && j >= 1) { - dswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); - } - if (j >= 1) { - goto L120; - } - -/* Set KB to the number of columns factorized */ - - *kb = k - 1; - - } - return 0; - -/* End of DLASYF */ - -} /* dlasyf_ */ diff --git a/3rdparty/lapack/dlatrd.c b/3rdparty/lapack/dlatrd.c deleted file mode 100644 index 4c80a5b..0000000 --- a/3rdparty/lapack/dlatrd.c +++ /dev/null @@ -1,355 +0,0 @@ -/* dlatrd.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 doublereal c_b6 = 1.; -static integer c__1 = 1; -static doublereal c_b16 = 0.; - -/* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal * - a, integer *lda, doublereal *e, doublereal *tau, doublereal *w, - integer *ldw) -{ - /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, iw; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - doublereal alpha; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *), daxpy_(integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *), - dsymv_(char *, 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 */ -/* ======= */ - -/* DLATRD reduces NB rows and columns of a real symmetric matrix A to */ -/* symmetric tridiagonal form by an orthogonal similarity */ -/* transformation Q' * A * Q, and returns the matrices V and W which are */ -/* needed to apply the transformation to the unreduced part of A. */ - -/* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a */ -/* matrix, of which the upper triangle is supplied; */ -/* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a */ -/* matrix, of which the lower triangle is supplied. */ - -/* This is an auxiliary routine called by DSYTRD. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* NB (input) INTEGER */ -/* The number of rows and columns to be reduced. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit: */ -/* if UPLO = 'U', the last NB columns have been reduced to */ -/* tridiagonal form, with the diagonal elements overwriting */ -/* the diagonal elements of A; the elements above the diagonal */ -/* with the array TAU, represent the orthogonal matrix Q as a */ -/* product of elementary reflectors; */ -/* if UPLO = 'L', the first NB columns have been reduced to */ -/* tridiagonal form, with the diagonal elements overwriting */ -/* the diagonal elements of A; 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 >= (1,N). */ - -/* E (output) DOUBLE PRECISION array, dimension (N-1) */ -/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */ -/* elements of the last NB columns of the reduced matrix; */ -/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */ -/* the first NB columns of the reduced matrix. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors, stored in */ -/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */ -/* See Further Details. */ - -/* W (output) DOUBLE PRECISION array, dimension (LDW,NB) */ -/* The n-by-nb matrix W required to update the unreduced part */ -/* of A. */ - -/* LDW (input) INTEGER */ -/* The leading dimension of the array W. LDW >= max(1,N). */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n) H(n-1) . . . H(n-nb+1). */ - -/* 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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */ -/* and tau in TAU(i-1). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(nb). */ - -/* 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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ -/* and tau in TAU(i). */ - -/* The elements of the vectors v together form the n-by-nb matrix V */ -/* which is needed, with W, to apply the transformation to the unreduced */ -/* part of the matrix, using a symmetric rank-2k update of the form: */ -/* A := A - V*W' - W*V'. */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5 and nb = 2: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( a a a v4 v5 ) ( d ) */ -/* ( a a v4 v5 ) ( 1 d ) */ -/* ( a 1 v5 ) ( v1 1 a ) */ -/* ( d 1 ) ( v1 v2 a a ) */ -/* ( d ) ( v1 v2 a a a ) */ - -/* where d denotes a diagonal element of the reduced matrix, a denotes */ -/* an element of the original matrix that is unchanged, and vi denotes */ -/* an element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --e; - --tau; - w_dim1 = *ldw; - w_offset = 1 + w_dim1; - w -= w_offset; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - - if (lsame_(uplo, "U")) { - -/* Reduce last NB columns of upper triangle */ - - i__1 = *n - *nb + 1; - for (i__ = *n; i__ >= i__1; --i__) { - iw = i__ - *n + *nb; - if (i__ < *n) { - -/* Update A(1:i,i) */ - - i__2 = *n - i__; - dgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & - c_b6, &a[i__ * a_dim1 + 1], &c__1); - i__2 = *n - i__; - dgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & - c_b6, &a[i__ * a_dim1 + 1], &c__1); - } - if (i__ > 1) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(1:i-2,i) */ - - i__2 = i__ - 1; - dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + - 1], &c__1, &tau[i__ - 1]); - e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; - a[i__ - 1 + i__ * a_dim1] = 1.; - -/* Compute W(1:i-1,i) */ - - i__2 = i__ - 1; - dsymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * - a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], & - c__1); - if (i__ < *n) { - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, & - c_b16, &w[i__ + 1 + iw * w_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, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, & - c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * - w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); - } - i__2 = i__ - 1; - dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); - i__2 = i__ - 1; - alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1], - &c__1, &a[i__ * a_dim1 + 1], &c__1); - i__2 = i__ - 1; - daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * - w_dim1 + 1], &c__1); - } - -/* L10: */ - } - } else { - -/* Reduce first NB columns of lower triangle */ - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Update A(i:n,i) */ - - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, - &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], & - c__1); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, - &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], & - c__1); - if (i__ < *n) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(i+2:n,i) */ - - i__2 = *n - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ - i__ * a_dim1], &c__1, &tau[i__]); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.; - -/* Compute W(i+1:n,i) */ - - i__2 = *n - i__; - dsymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1] -, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], - ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ * w_dim1 + 1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + - a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ * w_dim1 + 1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + - w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ * - w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - i__2 = *n - i__; - daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - } - -/* L20: */ - } - } - - return 0; - -/* End of DLATRD */ - -} /* dlatrd_ */ diff --git a/3rdparty/lapack/dlauu2.c b/3rdparty/lapack/dlauu2.c deleted file mode 100644 index f805c64..0000000 --- a/3rdparty/lapack/dlauu2.c +++ /dev/null @@ -1,183 +0,0 @@ -/* dlauu2.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 integer c__1 = 1; - -/* Subroutine */ int dlauu2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - doublereal aii; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *); - logical upper; - 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 */ -/* ======= */ - -/* DLAUU2 computes the product U * U' or L' * L, where the triangular */ -/* factor U or L is stored in the upper or lower triangular part of */ -/* the array A. */ - -/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* overwriting the factor U in A. */ -/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* overwriting the factor L in A. */ - -/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the triangular factor stored in the array A */ -/* is upper or lower triangular: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the triangular factor U or L. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L. */ -/* On exit, if UPLO = 'U', the upper triangle of A is */ -/* overwritten with the upper triangle of the product U * U'; */ -/* if UPLO = 'L', the lower triangle of A is overwritten with */ -/* the lower triangle of the product L' * L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAUU2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the product U * U'. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - aii = a[i__ + i__ * a_dim1]; - if (i__ < *n) { - i__2 = *n - i__ + 1; - a[i__ + i__ * a_dim1] = ddot_(&i__2, &a[i__ + i__ * a_dim1], - lda, &a[i__ + i__ * a_dim1], lda); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b7, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & - aii, &a[i__ * a_dim1 + 1], &c__1); - } else { - dscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1); - } -/* L10: */ - } - - } else { - -/* Compute the product L' * L. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - aii = a[i__ + i__ * a_dim1]; - if (i__ < *n) { - i__2 = *n - i__ + 1; - a[i__ + i__ * a_dim1] = ddot_(&i__2, &a[i__ + i__ * a_dim1], & - c__1, &a[i__ + i__ * a_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b7, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &aii, &a[i__ - + a_dim1], lda); - } else { - dscal_(&i__, &aii, &a[i__ + a_dim1], lda); - } -/* L20: */ - } - } - - return 0; - -/* End of DLAUU2 */ - -} /* dlauu2_ */ diff --git a/3rdparty/lapack/dlauum.c b/3rdparty/lapack/dlauum.c deleted file mode 100644 index f1bdf33..0000000 --- a/3rdparty/lapack/dlauum.c +++ /dev/null @@ -1,217 +0,0 @@ -/* dlauum.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_b15 = 1.; - -/* Subroutine */ int dlauum_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, ib, nb; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *); - logical upper; - extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *), dlauu2_(char *, integer *, - doublereal *, integer *, integer *), xerbla_(char *, - integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAUUM computes the product U * U' or L' * L, where the triangular */ -/* factor U or L is stored in the upper or lower triangular part of */ -/* the array A. */ - -/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* overwriting the factor U in A. */ -/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* overwriting the factor L in A. */ - -/* This is the blocked form of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the triangular factor stored in the array A */ -/* is upper or lower triangular: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the triangular factor U or L. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L. */ -/* On exit, if UPLO = 'U', the upper triangle of A is */ -/* overwritten with the upper triangle of the product U * U'; */ -/* if UPLO = 'L', the lower triangle of A is overwritten with */ -/* the lower triangle of the product L' * L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAUUM", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DLAUUM", uplo, n, &c_n1, &c_n1, &c_n1); - - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - dlauu2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute the product U * U'. */ - - i__1 = *n; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = min(i__3,i__4); - i__3 = i__ - 1; - dtrmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, - &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 - + 1], lda) - ; - dlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - dgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & - c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + - (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * - a_dim1 + 1], lda); - i__3 = *n - i__ - ib + 1; - dsyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ - i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + - i__ * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the product L' * L. */ - - i__2 = *n; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = min(i__3,i__4); - i__3 = i__ - 1; - dtrmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & - c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], - lda); - dlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - dgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & - c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + - ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); - i__3 = *n - i__ - ib + 1; - dsyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + - ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * - a_dim1], lda); - } -/* L20: */ - } - } - } - - return 0; - -/* End of DLAUUM */ - -} /* dlauum_ */ diff --git a/3rdparty/lapack/dnrm2.c b/3rdparty/lapack/dnrm2.c deleted file mode 100644 index b1546e8..0000000 --- a/3rdparty/lapack/dnrm2.c +++ /dev/null @@ -1,95 +0,0 @@ -/* dnrm2.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 dnrm2_(integer *n, doublereal *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - doublereal ret_val, d__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer ix; - doublereal ssq, norm, scale, absxi; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DNRM2 returns the euclidean norm of a vector via the function */ -/* name, so that */ - -/* DNRM2 := sqrt( x'*x ) */ - - -/* -- This version written on 25-October-1982. */ -/* Modified on 14-October-1993 to inline the call to DLASSQ. */ -/* Sven Hammarling, Nag Ltd. */ - - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n < 1 || *incx < 1) { - norm = 0.; - } else if (*n == 1) { - norm = abs(x[1]); - } else { - scale = 0.; - ssq = 1.; -/* The following loop is equivalent to this call to the LAPACK */ -/* auxiliary routine: */ -/* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */ - - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.) { - absxi = (d__1 = x[ix], abs(d__1)); - if (scale < absxi) { -/* Computing 2nd power */ - d__1 = scale / absxi; - ssq = ssq * (d__1 * d__1) + 1.; - scale = absxi; - } else { -/* Computing 2nd power */ - d__1 = absxi / scale; - ssq += d__1 * d__1; - } - } -/* L10: */ - } - norm = scale * sqrt(ssq); - } - - ret_val = norm; - return ret_val; - -/* End of DNRM2. */ - -} /* dnrm2_ */ diff --git a/3rdparty/lapack/dorg2r.c b/3rdparty/lapack/dorg2r.c deleted file mode 100644 index 2889004..0000000 --- a/3rdparty/lapack/dorg2r.c +++ /dev/null @@ -1,175 +0,0 @@ -/* dorg2r.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 dorg2r_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal d__1; - - /* Local variables */ - integer i__, j, l; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlarf_(char *, integer *, integer *, doublereal *, - 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 */ -/* ======= */ - -/* DORG2R generates an m by n real matrix Q with orthonormal columns, */ -/* which is defined as the first n columns of a product of k elementary */ -/* reflectors of order m */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by DGEQRF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. M >= N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. N >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the i-th column must contain the vector which */ -/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ -/* returned by DGEQRF in the first k columns of its array */ -/* argument A. */ -/* On exit, the m-by-n matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQRF. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. 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 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORG2R", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - -/* Initialise columns k+1:n to columns of the unit matrix */ - - i__1 = *n; - for (j = *k + 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; -/* L10: */ - } - a[j + j * a_dim1] = 1.; -/* L20: */ - } - - for (i__ = *k; i__ >= 1; --i__) { - -/* Apply H(i) to A(i:m,i:n) from the left */ - - if (i__ < *n) { - a[i__ + i__ * a_dim1] = 1.; - i__1 = *m - i__ + 1; - i__2 = *n - i__; - dlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ - i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); - } - if (i__ < *m) { - i__1 = *m - i__; - d__1 = -tau[i__]; - dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - } - a[i__ + i__ * a_dim1] = 1. - tau[i__]; - -/* Set A(1:i-1,i) to zero */ - - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a[l + i__ * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of DORG2R */ - -} /* dorg2r_ */ diff --git a/3rdparty/lapack/dorgbr.c b/3rdparty/lapack/dorgbr.c deleted file mode 100644 index 029b09c..0000000 --- a/3rdparty/lapack/dorgbr.c +++ /dev/null @@ -1,299 +0,0 @@ -/* dorgbr.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 dorgbr_(char *vect, integer *m, integer *n, integer *k, - 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; - - /* Local variables */ - integer i__, j, nb, mn; - extern logical lsame_(char *, char *); - integer iinfo; - logical wantq; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int dorglq_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - integer *), dorgqr_(integer *, integer *, integer *, doublereal *, - integer *, doublereal *, 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 */ -/* ======= */ - -/* DORGBR generates one of the real orthogonal matrices Q or P**T */ -/* determined by DGEBRD when reducing a real matrix A to bidiagonal */ -/* form: A = Q * B * P**T. Q and P**T are defined as products of */ -/* elementary reflectors H(i) or G(i) respectively. */ - -/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */ -/* is of order M: */ -/* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n */ -/* columns of Q, where m >= n >= k; */ -/* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an */ -/* M-by-M matrix. */ - -/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */ -/* is of order N: */ -/* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m */ -/* rows of P**T, where n >= m >= k; */ -/* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as */ -/* an N-by-N matrix. */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* Specifies whether the matrix Q or the matrix P**T is */ -/* required, as defined in the transformation applied by DGEBRD: */ -/* = 'Q': generate Q; */ -/* = 'P': generate P**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q or P**T to be returned. */ -/* M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q or P**T to be returned. */ -/* N >= 0. */ -/* If VECT = 'Q', M >= N >= min(M,K); */ -/* if VECT = 'P', N >= M >= min(N,K). */ - -/* K (input) INTEGER */ -/* If VECT = 'Q', the number of columns in the original M-by-K */ -/* matrix reduced by DGEBRD. */ -/* If VECT = 'P', the number of rows in the original K-by-N */ -/* matrix reduced by DGEBRD. */ -/* K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the vectors which define the elementary reflectors, */ -/* as returned by DGEBRD. */ -/* On exit, the M-by-N matrix Q or P**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension */ -/* (min(M,K)) if VECT = 'Q' */ -/* (min(N,K)) if VECT = 'P' */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i) or G(i), which determines Q or P**T, as */ -/* returned by DGEBRD in its array argument TAUQ or TAUP. */ - -/* 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,min(M,N)). */ -/* For optimum performance LWORK >= min(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 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. 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; - --tau; - --work; - - /* Function Body */ - *info = 0; - wantq = lsame_(vect, "Q"); - mn = min(*m,*n); - lquery = *lwork == -1; - if (! wantq && ! lsame_(vect, "P")) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && ( - *m > *n || *m < min(*n,*k))) { - *info = -3; - } else if (*k < 0) { - *info = -4; - } else if (*lda < max(1,*m)) { - *info = -6; - } else if (*lwork < max(1,mn) && ! lquery) { - *info = -9; - } - - if (*info == 0) { - if (wantq) { - nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1); - } else { - nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1); - } - lwkopt = max(1,mn) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGBR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - work[1] = 1.; - return 0; - } - - if (wantq) { - -/* Form Q, determined by a call to DGEBRD to reduce an m-by-k */ -/* matrix */ - - if (*m >= *k) { - -/* If m >= k, assume m >= n >= k */ - - dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); - - } else { - -/* If m < k, assume m = n */ - -/* Shift the vectors which define the elementary reflectors one */ -/* column to the right, and set the first row and column of Q */ -/* to those of the unit matrix */ - - for (j = *m; j >= 2; --j) { - a[j * a_dim1 + 1] = 0.; - i__1 = *m; - for (i__ = j + 1; i__ <= i__1; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; -/* L10: */ - } -/* L20: */ - } - a[a_dim1 + 1] = 1.; - i__1 = *m; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.; -/* L30: */ - } - if (*m > 1) { - -/* Form Q(2:m,2:m) */ - - i__1 = *m - 1; - i__2 = *m - 1; - i__3 = *m - 1; - dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ - 1], &work[1], lwork, &iinfo); - } - } - } else { - -/* Form P', determined by a call to DGEBRD to reduce a k-by-n */ -/* matrix */ - - if (*k < *n) { - -/* If k < n, assume k <= m <= n */ - - dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); - - } else { - -/* If k >= n, assume m = n */ - -/* Shift the vectors which define the elementary reflectors one */ -/* row downward, and set the first row and column of P' to */ -/* those of the unit matrix */ - - a[a_dim1 + 1] = 1.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.; -/* L40: */ - } - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - for (i__ = j - 1; i__ >= 2; --i__) { - a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1]; -/* L50: */ - } - a[j * a_dim1 + 1] = 0.; -/* L60: */ - } - if (*n > 1) { - -/* Form P'(2:n,2:n) */ - - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ - 1], &work[1], lwork, &iinfo); - } - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORGBR */ - -} /* dorgbr_ */ diff --git a/3rdparty/lapack/dorgl2.c b/3rdparty/lapack/dorgl2.c deleted file mode 100644 index 26b7f85..0000000 --- a/3rdparty/lapack/dorgl2.c +++ /dev/null @@ -1,175 +0,0 @@ -/* dorgl2.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 dorgl2_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal d__1; - - /* Local variables */ - integer i__, j, l; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlarf_(char *, integer *, integer *, doublereal *, - 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 */ -/* ======= */ - -/* DORGL2 generates an m by n real matrix Q with orthonormal rows, */ -/* which is defined as the first m rows of a product of k elementary */ -/* reflectors of order n */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGELQF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. N >= M. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. M >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the i-th row must contain the vector which defines */ -/* the elementary reflector H(i), for i = 1,2,...,k, as returned */ -/* by DGELQF in the first k rows of its array argument A. */ -/* On exit, the m-by-n matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGELQF. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. 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 < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGL2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - return 0; - } - - if (*k < *m) { - -/* Initialise rows k+1:m to rows of the unit matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = *k + 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; -/* L10: */ - } - if (j > *k && j <= *m) { - a[j + j * a_dim1] = 1.; - } -/* L20: */ - } - } - - for (i__ = *k; i__ >= 1; --i__) { - -/* Apply H(i) to A(i:m,i:n) from the right */ - - if (i__ < *n) { - if (i__ < *m) { - a[i__ + i__ * a_dim1] = 1.; - i__1 = *m - i__; - i__2 = *n - i__ + 1; - dlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & - tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); - } - i__1 = *n - i__; - d__1 = -tau[i__]; - dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda); - } - a[i__ + i__ * a_dim1] = 1. - tau[i__]; - -/* Set A(i,1:i-1) to zero */ - - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a[i__ + l * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of DORGL2 */ - -} /* dorgl2_ */ diff --git a/3rdparty/lapack/dorglq.c b/3rdparty/lapack/dorglq.c deleted file mode 100644 index ee11743..0000000 --- a/3rdparty/lapack/dorglq.c +++ /dev/null @@ -1,280 +0,0 @@ -/* dorglq.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 dorglq_(integer *m, integer *n, integer *k, 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; - - /* Local variables */ - integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int dorgl2_(integer *, 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 */ -/* ======= */ - -/* DORGLQ generates an M-by-N real matrix Q with orthonormal rows, */ -/* which is defined as the first M rows of a product of K elementary */ -/* reflectors of order N */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGELQF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. N >= M. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. M >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the i-th row must contain the vector which defines */ -/* the elementary reflector H(i), for i = 1,2,...,k, as returned */ -/* by DGELQF in the first k rows of its array argument A. */ -/* On exit, the M-by-N matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGELQF. */ - -/* 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 has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. 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, "DORGLQ", " ", m, n, k, &c_n1); - lwkopt = max(1,*m) * nb; - work[1] = (doublereal) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*lwork < max(1,*m) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGLQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m <= 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, "DORGLQ", " ", m, n, k, &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, "DORGLQ", " ", m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the last block. */ -/* The first kk rows are handled by the block method. */ - - ki = (*k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); - -/* Set A(kk+1:m,1:kk) to zero. */ - - i__1 = kk; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = kk + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the last or only block. */ - - if (kk < *m) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); - } - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *m) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__2 = *n - i__ + 1; - dlarft_("Forward", "Rowwise", &i__2, &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__2 = *m - i__ - ib + 1; - i__3 = *n - i__ + 1; - dlarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, & - i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & - ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + - 1], &ldwork); - } - -/* Apply H' to columns i:n of current block */ - - i__2 = *n - i__ + 1; - dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); - -/* Set columns 1:i-1 of current block to zero */ - - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = i__ + ib - 1; - for (l = i__; l <= i__3; ++l) { - a[l + j * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (doublereal) iws; - return 0; - -/* End of DORGLQ */ - -} /* dorglq_ */ diff --git a/3rdparty/lapack/dorgqr.c b/3rdparty/lapack/dorgqr.c deleted file mode 100644 index 8f34e49..0000000 --- a/3rdparty/lapack/dorgqr.c +++ /dev/null @@ -1,281 +0,0 @@ -/* dorgqr.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 dorgqr_(integer *m, integer *n, integer *k, 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; - - /* Local variables */ - integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int dorg2r_(integer *, 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 */ -/* ======= */ - -/* DORGQR generates an M-by-N real matrix Q with orthonormal columns, */ -/* which is defined as the first N columns of a product of K elementary */ -/* reflectors of order M */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by DGEQRF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. M >= N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. N >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the i-th column must contain the vector which */ -/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ -/* returned by DGEQRF in the first k columns of its array */ -/* argument A. */ -/* On exit, the M-by-N matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQRF. */ - -/* 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 has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. 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, "DORGQR", " ", m, n, k, &c_n1); - lwkopt = max(1,*n) * nb; - work[1] = (doublereal) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*lwork < max(1,*n) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGQR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n <= 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, "DORGQR", " ", m, n, k, &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, "DORGQR", " ", m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the last block. */ -/* The first kk columns are handled by the block method. */ - - ki = (*k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); - -/* Set A(1:kk,kk+1:n) to zero. */ - - i__1 = *n; - for (j = kk + 1; j <= i__1; ++j) { - i__2 = kk; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the last or only block. */ - - if (kk < *n) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); - } - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *n) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__2 = *m - i__ + 1; - dlarft_("Forward", "Columnwise", &i__2, &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__2 = *m - i__ + 1; - i__3 = *n - i__ - ib + 1; - dlarfb_("Left", "No transpose", "Forward", "Columnwise", & - i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ - 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & - work[ib + 1], &ldwork); - } - -/* Apply H to rows i:m of current block */ - - i__2 = *m - i__ + 1; - dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); - -/* Set rows 1:i-1 of current block to zero */ - - i__2 = i__ + ib - 1; - for (j = i__; j <= i__2; ++j) { - i__3 = i__ - 1; - for (l = 1; l <= i__3; ++l) { - a[l + j * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (doublereal) iws; - return 0; - -/* End of DORGQR */ - -} /* dorgqr_ */ diff --git a/3rdparty/lapack/dorm2l.c b/3rdparty/lapack/dorm2l.c deleted file mode 100644 index f826a2d..0000000 --- a/3rdparty/lapack/dorm2l.c +++ /dev/null @@ -1,231 +0,0 @@ -/* dorm2l.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 dorm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, mi, ni, nq; - doublereal aii; - logical left; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, 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 */ -/* ======= */ - -/* DORM2L overwrites the general real m by n matrix C with */ - -/* Q * C if SIDE = 'L' and TRANS = 'N', or */ - -/* Q'* C if SIDE = 'L' and TRANS = 'T', or */ - -/* C * Q if SIDE = 'R' and TRANS = 'N', or */ - -/* C * Q' if SIDE = 'R' and TRANS = 'T', */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q' from the Left */ -/* = 'R': apply Q or Q' from the Right */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply Q (No transpose) */ -/* = 'T': apply Q' (Transpose) */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */ -/* The i-th column must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGEQLF in the last k columns of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If SIDE = 'L', LDA >= max(1,M); */ -/* if SIDE = 'R', LDA >= max(1,N). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQLF. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the m by n matrix C. */ -/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension */ -/* (N) if SIDE = 'L', */ -/* (M) if SIDE = 'R' */ - -/* 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 arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORM2L", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(1:m-k+i,1:n) */ - - mi = *m - *k + i__; - } else { - -/* H(i) is applied to C(1:m,1:n-k+i) */ - - ni = *n - *k + i__; - } - -/* Apply H(i) */ - - aii = a[nq - *k + i__ + i__ * a_dim1]; - a[nq - *k + i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[ - c_offset], ldc, &work[1]); - a[nq - *k + i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DORM2L */ - -} /* dorm2l_ */ diff --git a/3rdparty/lapack/dorm2r.c b/3rdparty/lapack/dorm2r.c deleted file mode 100644 index 22d3988..0000000 --- a/3rdparty/lapack/dorm2r.c +++ /dev/null @@ -1,235 +0,0 @@ -/* dorm2r.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 dorm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, ic, jc, mi, ni, nq; - doublereal aii; - logical left; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, 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 */ -/* ======= */ - -/* DORM2R overwrites the general real m by n matrix C with */ - -/* Q * C if SIDE = 'L' and TRANS = 'N', or */ - -/* Q'* C if SIDE = 'L' and TRANS = 'T', or */ - -/* C * Q if SIDE = 'R' and TRANS = 'N', or */ - -/* C * Q' if SIDE = 'R' and TRANS = 'T', */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q' from the Left */ -/* = 'R': apply Q or Q' from the Right */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply Q (No transpose) */ -/* = 'T': apply Q' (Transpose) */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */ -/* The i-th column must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGEQRF in the first k columns of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If SIDE = 'L', LDA >= max(1,M); */ -/* if SIDE = 'R', LDA >= max(1,N). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQRF. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the m by n matrix C. */ -/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension */ -/* (N) if SIDE = 'L', */ -/* (M) if SIDE = 'R' */ - -/* 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 arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORM2R", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H(i) is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H(i) */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1]); - a[i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DORM2R */ - -} /* dorm2r_ */ diff --git a/3rdparty/lapack/dormbr.c b/3rdparty/lapack/dormbr.c deleted file mode 100644 index 5b96dad..0000000 --- a/3rdparty/lapack/dormbr.c +++ /dev/null @@ -1,360 +0,0 @@ -/* dormbr.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; - -/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i1, i2, nb, mi, ni, nq, nw; - logical left; - extern logical lsame_(char *, char *); - integer iinfo; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *); - logical notran; - extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *); - logical applyq; - char transt[1]; - 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 */ -/* ======= */ - -/* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C */ -/* with */ -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C */ -/* with */ -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': P * C C * P */ -/* TRANS = 'T': P**T * C C * P**T */ - -/* Here Q and P**T are the orthogonal matrices determined by DGEBRD when */ -/* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and */ -/* P**T are defined as products of elementary reflectors H(i) and G(i) */ -/* respectively. */ - -/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */ -/* order of the orthogonal matrix Q or P**T that is applied. */ - -/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */ -/* if nq >= k, Q = H(1) H(2) . . . H(k); */ -/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */ - -/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */ -/* if k < nq, P = G(1) G(2) . . . G(k); */ -/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* = 'Q': apply Q or Q**T; */ -/* = 'P': apply P or P**T. */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q, Q**T, P or P**T from the Left; */ -/* = 'R': apply Q, Q**T, P or P**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q or P; */ -/* = 'T': Transpose, apply Q**T or P**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* If VECT = 'Q', the number of columns in the original */ -/* matrix reduced by DGEBRD. */ -/* If VECT = 'P', the number of rows in the original */ -/* matrix reduced by DGEBRD. */ -/* K >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,min(nq,K)) if VECT = 'Q' */ -/* (LDA,nq) if VECT = 'P' */ -/* The vectors which define the elementary reflectors H(i) and */ -/* G(i), whose products determine the matrices Q and P, as */ -/* returned by DGEBRD. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If VECT = 'Q', LDA >= max(1,nq); */ -/* if VECT = 'P', LDA >= max(1,min(nq,K)). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i) or G(i) which determines Q or P, as returned */ -/* by DGEBRD in the array argument TAUQ or TAUP. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q */ -/* or P*C or P**T*C or C*P or C*P**T. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - applyq = lsame_(vect, "Q"); - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q or P and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! applyq && ! lsame_(vect, "P")) { - *info = -1; - } else if (! left && ! lsame_(side, "R")) { - *info = -2; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*k < 0) { - *info = -6; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = 1, i__2 = min(nq,*k); - if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) { - *info = -8; - } else if (*ldc < max(1,*m)) { - *info = -11; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -13; - } - } - - if (*info == 0) { - if (applyq) { - if (left) { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__1, n, &i__2, &c_n1); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__1, &i__2, &c_n1); - } - } else { - if (left) { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, "DORMLQ", ch__1, &i__1, n, &i__2, &c_n1); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, "DORMLQ", ch__1, m, &i__1, &i__2, &c_n1); - } - } - lwkopt = max(1,nw) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMBR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - work[1] = 1.; - if (*m == 0 || *n == 0) { - return 0; - } - - if (applyq) { - -/* Apply Q */ - - if (nq >= *k) { - -/* Q was determined by a call to DGEBRD with nq >= k */ - - dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo); - } else if (nq > 1) { - -/* Q was determined by a call to DGEBRD with nq < k */ - - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] -, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); - } - } else { - -/* Apply P */ - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - if (nq > *k) { - -/* P was determined by a call to DGEBRD with nq > k */ - - dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo); - } else if (nq > 1) { - -/* P was determined by a call to DGEBRD with nq <= k */ - - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, - &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & - iinfo); - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORMBR */ - -} /* dormbr_ */ diff --git a/3rdparty/lapack/dorml2.c b/3rdparty/lapack/dorml2.c deleted file mode 100644 index 58382f0..0000000 --- a/3rdparty/lapack/dorml2.c +++ /dev/null @@ -1,231 +0,0 @@ -/* dorml2.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 dorml2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, ic, jc, mi, ni, nq; - doublereal aii; - logical left; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, 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 */ -/* ======= */ - -/* DORML2 overwrites the general real m by n matrix C with */ - -/* Q * C if SIDE = 'L' and TRANS = 'N', or */ - -/* Q'* C if SIDE = 'L' and TRANS = 'T', or */ - -/* C * Q if SIDE = 'R' and TRANS = 'N', or */ - -/* C * Q' if SIDE = 'R' and TRANS = 'T', */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q' from the Left */ -/* = 'R': apply Q or Q' from the Right */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply Q (No transpose) */ -/* = 'T': apply Q' (Transpose) */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGELQF in the first k rows of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,K). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGELQF. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the m by n matrix C. */ -/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension */ -/* (N) if SIDE = 'L', */ -/* (M) if SIDE = 'R' */ - -/* 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 arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,*k)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORML2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H(i) is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H(i) */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1]); - a[i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DORML2 */ - -} /* dorml2_ */ diff --git a/3rdparty/lapack/dormlq.c b/3rdparty/lapack/dormlq.c deleted file mode 100644 index d70ae7d..0000000 --- a/3rdparty/lapack/dormlq.c +++ /dev/null @@ -1,334 +0,0 @@ -/* dormlq.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 integer c__65 = 65; - -/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i__; - doublereal t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; - logical left; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, 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 *); - logical notran; - integer ldwork; - char transt[1]; - 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 */ -/* ======= */ - -/* DORMLQ overwrites the general real M-by-N matrix C with */ - -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q; */ -/* = 'T': Transpose, apply Q**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGELQF in the first k rows of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,K). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGELQF. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,*k)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - -/* Determine the block size. NB may be at most NBMAX, where NBMAX */ -/* is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1); - nb = min(i__1,i__2); - lwkopt = max(1,nw) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMLQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__4 = nq - i__ + 1; - dlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], - lda, &tau[i__], t, &c__65); - if (left) { - -/* H or H' is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H or H' is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H or H' */ - - dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ - + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], - ldc, &work[1], &ldwork); -/* L10: */ - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORMLQ */ - -} /* dormlq_ */ diff --git a/3rdparty/lapack/dormql.c b/3rdparty/lapack/dormql.c deleted file mode 100644 index d0b2a16..0000000 --- a/3rdparty/lapack/dormql.c +++ /dev/null @@ -1,327 +0,0 @@ -/* dormql.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 integer c__65 = 65; - -/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i__; - doublereal t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws; - logical left; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, 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 *); - logical notran; - 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 */ -/* ======= */ - -/* DORMQL overwrites the general real M-by-N matrix C with */ - -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q; */ -/* = 'T': Transpose, apply Q**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */ -/* The i-th column must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGEQLF in the last k columns of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If SIDE = 'L', LDA >= max(1,M); */ -/* if SIDE = 'R', LDA >= max(1,N). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQLF. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = max(1,*n); - } else { - nq = *n; - nw = max(1,*m); - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - - if (*info == 0) { - if (*m == 0 || *n == 0) { - lwkopt = 1; - } else { - -/* Determine the block size. NB may be at most NBMAX, where */ -/* NBMAX is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQL", ch__1, m, n, k, &c_n1); - nb = min(i__1,i__2); - lwkopt = nw * nb; - } - work[1] = (doublereal) lwkopt; - - if (*lwork < nw && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMQL", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQL", ch__1, m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__4 = nq - *k + i__ + ib - 1; - dlarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] -, lda, &tau[i__], t, &c__65); - if (left) { - -/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */ - - mi = *m - *k + i__ + ib - 1; - } else { - -/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */ - - ni = *n - *k + i__ + ib - 1; - } - -/* Apply H or H' */ - - dlarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[ - i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, & - work[1], &ldwork); -/* L10: */ - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORMQL */ - -} /* dormql_ */ diff --git a/3rdparty/lapack/dormqr.c b/3rdparty/lapack/dormqr.c deleted file mode 100644 index 2d5d28e..0000000 --- a/3rdparty/lapack/dormqr.c +++ /dev/null @@ -1,327 +0,0 @@ -/* dormqr.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 integer c__65 = 65; - -/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i__; - doublereal t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; - logical left; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, 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 *); - logical notran; - 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 */ -/* ======= */ - -/* DORMQR overwrites the general real M-by-N matrix C with */ - -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q; */ -/* = 'T': Transpose, apply Q**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */ -/* The i-th column must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGEQRF in the first k columns of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If SIDE = 'L', LDA >= max(1,M); */ -/* if SIDE = 'R', LDA >= max(1,N). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQRF. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - -/* Determine the block size. NB may be at most NBMAX, where NBMAX */ -/* is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1); - nb = min(i__1,i__2); - lwkopt = max(1,nw) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMQR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__4 = nq - i__ + 1; - dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], t, &c__65) - ; - if (left) { - -/* H or H' is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H or H' is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H or H' */ - - dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ - i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * - c_dim1], ldc, &work[1], &ldwork); -/* L10: */ - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORMQR */ - -} /* dormqr_ */ diff --git a/3rdparty/lapack/dormtr.c b/3rdparty/lapack/dormtr.c deleted file mode 100644 index 3d844c9..0000000 --- a/3rdparty/lapack/dormtr.c +++ /dev/null @@ -1,295 +0,0 @@ -/* dormtr.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; - -/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i1, i2, nb, mi, ni, nq, nw; - logical left; - extern logical lsame_(char *, char *); - integer iinfo; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int dormql_(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 *); - 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 */ -/* ======= */ - -/* DORMTR overwrites the general real M-by-N matrix C with */ - -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* where Q is a real orthogonal matrix of order nq, with nq = m if */ -/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ -/* nq-1 elementary reflectors, as returned by DSYTRD: */ - -/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ - -/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A contains elementary reflectors */ -/* from DSYTRD; */ -/* = 'L': Lower triangle of A contains elementary reflectors */ -/* from DSYTRD. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q; */ -/* = 'T': Transpose, apply Q**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,M) if SIDE = 'L' */ -/* (LDA,N) if SIDE = 'R' */ -/* The vectors which define the elementary reflectors, as */ -/* returned by DSYTRD. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */ - -/* TAU (input) DOUBLE PRECISION array, dimension */ -/* (M-1) if SIDE = 'L' */ -/* (N-1) if SIDE = 'R' */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DSYTRD. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T")) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - if (upper) { - if (left) { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, "DORMQL", ch__1, &i__2, n, &i__3, &c_n1); - } else { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, "DORMQL", ch__1, m, &i__2, &i__3, &c_n1); - } - } else { - if (left) { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__2, n, &i__3, &c_n1); - } else { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__2, &i__3, &c_n1); - } - } - lwkopt = max(1,nw) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__2 = -(*info); - xerbla_("DORMTR", &i__2); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || nq == 1) { - work[1] = 1.; - return 0; - } - - if (left) { - mi = *m - 1; - ni = *n; - } else { - mi = *m; - ni = *n - 1; - } - - if (upper) { - -/* Q was determined by a call to DSYTRD with UPLO = 'U' */ - - i__2 = nq - 1; - dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & - tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo); - } else { - -/* Q was determined by a call to DSYTRD with UPLO = 'L' */ - - if (left) { - i1 = 2; - i2 = 1; - } else { - i1 = 1; - i2 = 2; - } - i__2 = nq - 1; - dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & - c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORMTR */ - -} /* dormtr_ */ diff --git a/3rdparty/lapack/dpotf2.c b/3rdparty/lapack/dpotf2.c deleted file mode 100644 index bc6d77c..0000000 --- a/3rdparty/lapack/dpotf2.c +++ /dev/null @@ -1,224 +0,0 @@ -/* dpotf2.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_b10 = -1.; -static doublereal c_b12 = 1.; - -/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - doublereal d__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer j; - doublereal ajj; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *); - logical upper; - extern logical disnan_(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 */ -/* ======= */ - -/* DPOTF2 computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U' * U , if UPLO = 'U', or */ -/* A = L * L', if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U'*U or A = L*L'. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, the leading minor of order k is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. 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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute U(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1, - &a[j * a_dim1 + 1], &c__1); - if (ajj <= 0. || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of row J. */ - - if (j < *n) { - i__2 = j - 1; - i__3 = *n - j; - dgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 - + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( - j + 1) * a_dim1], lda); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute L(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j - + a_dim1], lda); - if (ajj <= 0. || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of column J. */ - - if (j < *n) { - i__2 = *n - j; - i__3 = j - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + - a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + - j * a_dim1], &c__1); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); - } -/* L20: */ - } - } - goto L40; - -L30: - *info = j; - -L40: - return 0; - -/* End of DPOTF2 */ - -} /* dpotf2_ */ diff --git a/3rdparty/lapack/dpotrf.c b/3rdparty/lapack/dpotrf.c deleted file mode 100644 index 5983abb..0000000 --- a/3rdparty/lapack/dpotrf.c +++ /dev/null @@ -1,245 +0,0 @@ -/* dpotrf.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_b13 = -1.; -static doublereal c_b14 = 1.; - -/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer j, jb, nb; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *); - logical upper; - extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *), dpotf2_(char *, integer *, - doublereal *, integer *, integer *), xerbla_(char *, - integer *); - extern integer ilaenv_(integer *, char *, char *, 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 */ -/* ======= */ - -/* DPOTRF computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the block version of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= 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, the leading minor of order i is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. 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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code. */ - - dpotf2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code. */ - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - i__3 = j - 1; - dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j * - a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda); - dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block row. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, & - c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) * - a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) * - a_dim1], lda); - i__3 = *n - j - jb + 1; - dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, & - i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j - + jb) * a_dim1], lda); - } -/* L10: */ - } - - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__2 = *n; - i__1 = nb; - for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - i__3 = j - 1; - dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j + - a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda); - dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block column. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, & - c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1], - lda, &c_b14, &a[j + jb + j * a_dim1], lda); - i__3 = *n - j - jb + 1; - dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, & - jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb + - j * a_dim1], lda); - } -/* L20: */ - } - } - } - goto L40; - -L30: - *info = *info + j - 1; - -L40: - return 0; - -/* End of DPOTRF */ - -} /* dpotrf_ */ diff --git a/3rdparty/lapack/dpotri.c b/3rdparty/lapack/dpotri.c deleted file mode 100644 index d69bd45..0000000 --- a/3rdparty/lapack/dpotri.c +++ /dev/null @@ -1,125 +0,0 @@ -/* dpotri.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 dpotri_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - - /* Local variables */ - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *), dlauum_( - char *, integer *, doublereal *, integer *, integer *), - dtrtri_(char *, char *, integer *, doublereal *, integer *, - integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOTRI computes the inverse of a real symmetric positive definite */ -/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ -/* computed by DPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T, as computed by */ -/* DPOTRF. */ -/* On exit, the upper or lower triangle of the (symmetric) */ -/* inverse of A, overwriting the input factor U or L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= 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, the (i,i) element of the factor U or L is */ -/* zero, and the inverse could not be computed. */ - -/* ===================================================================== */ - -/* .. 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; - - /* Function Body */ - *info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Invert the triangular Cholesky factor U or L. */ - - dtrtri_(uplo, "Non-unit", n, &a[a_offset], lda, info); - if (*info > 0) { - return 0; - } - -/* Form inv(U)*inv(U)' or inv(L)'*inv(L). */ - - dlauum_(uplo, n, &a[a_offset], lda, info); - - return 0; - -/* End of DPOTRI */ - -} /* dpotri_ */ diff --git a/3rdparty/lapack/dpotrs.c b/3rdparty/lapack/dpotrs.c deleted file mode 100644 index 2f2ca66..0000000 --- a/3rdparty/lapack/dpotrs.c +++ /dev/null @@ -1,166 +0,0 @@ -/* dpotrs.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_b9 = 1.; - -/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, 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 *); - logical upper; - 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 */ -/* ======= */ - -/* DPOTRS solves a system of linear equations A*X = B with a symmetric */ -/* positive definite matrix A using the Cholesky factorization */ -/* A = U**T*U or A = L*L**T computed by DPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* 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 triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* 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; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *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 = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B where A = U'*U. */ - -/* Solve U'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, &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_b9, & - a[a_offset], lda, &b[b_offset], ldb); - } else { - -/* Solve A*X = B where A = L*L'. */ - -/* Solve L*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb); - -/* Solve L'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb); - } - - return 0; - -/* End of DPOTRS */ - -} /* dpotrs_ */ diff --git a/3rdparty/lapack/drot.c b/3rdparty/lapack/drot.c deleted file mode 100644 index 8e17f35..0000000 --- a/3rdparty/lapack/drot.c +++ /dev/null @@ -1,86 +0,0 @@ -/* drot.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 drot_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy, doublereal *c__, doublereal *s) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, ix, iy; - doublereal dtemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* applies a plane rotation. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ - /* 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__) { - dtemp = *c__ * dx[ix] + *s * dy[iy]; - dy[iy] = *c__ * dy[iy] - *s * dx[ix]; - dx[ix] = dtemp; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - -L20: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = *c__ * dx[i__] + *s * dy[i__]; - dy[i__] = *c__ * dy[i__] - *s * dx[i__]; - dx[i__] = dtemp; -/* L30: */ - } - return 0; -} /* drot_ */ diff --git a/3rdparty/lapack/dscal.c b/3rdparty/lapack/dscal.c deleted file mode 100644 index f39dfd4..0000000 --- a/3rdparty/lapack/dscal.c +++ /dev/null @@ -1,96 +0,0 @@ -/* dscal.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 dscal_(integer *n, doublereal *da, doublereal *dx, - integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, m, mp1, nincx; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ -/* * */ -/* scales a vector by a constant. */ -/* uses unrolled loops for increment equal to one. */ -/* 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 */ - if (*n <= 0 || *incx <= 0) { - return 0; - } - 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) { - dx[i__] = *da * dx[i__]; -/* L10: */ - } - return 0; - -/* code for increment equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__2 = m; - for (i__ = 1; i__ <= i__2; ++i__) { - dx[i__] = *da * dx[i__]; -/* L30: */ - } - if (*n < 5) { - return 0; - } -L40: - mp1 = m + 1; - i__2 = *n; - for (i__ = mp1; i__ <= i__2; i__ += 5) { - dx[i__] = *da * dx[i__]; - dx[i__ + 1] = *da * dx[i__ + 1]; - dx[i__ + 2] = *da * dx[i__ + 2]; - dx[i__ + 3] = *da * dx[i__ + 3]; - dx[i__ + 4] = *da * dx[i__ + 4]; -/* L50: */ - } - return 0; -} /* dscal_ */ diff --git a/3rdparty/lapack/dstebz.c b/3rdparty/lapack/dstebz.c deleted file mode 100644 index 9748de0..0000000 --- a/3rdparty/lapack/dstebz.c +++ /dev/null @@ -1,774 +0,0 @@ -/* dstebz.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 dstebz_(char *range, char *order, integer *n, doublereal - *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, - doublereal *d__, doublereal *e, integer *m, integer *nsplit, - doublereal *w, integer *iblock, integer *isplit, doublereal *work, - integer *iwork, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - doublereal d__1, d__2, d__3, d__4, d__5; - - /* Builtin functions */ - double sqrt(doublereal), log(doublereal); - - /* Local variables */ - integer j, ib, jb, ie, je, nb; - doublereal gl; - integer im, in; - doublereal gu; - integer iw; - doublereal wl, wu; - integer nwl; - doublereal ulp, wlu, wul; - integer nwu; - doublereal tmp1, tmp2; - integer iend, ioff, iout, itmp1, jdisc; - extern logical lsame_(char *, char *); - integer iinfo; - doublereal atoli; - integer iwoff; - doublereal bnorm; - integer itmax; - doublereal wkill, rtoli, 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; - doublereal safemn; - integer idumma[1]; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - integer idiscu, iorder; - logical ncnvrg; - doublereal pivmin; - logical toofew; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ -/* 8-18-00: Increase FUDGE factor for T3E (eca) */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEBZ computes the eigenvalues of a symmetric tridiagonal */ -/* matrix T. 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*1 */ -/* = '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*1 */ -/* = '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'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute tolerance for the eigenvalues. An eigenvalue */ -/* (or cluster) is considered to be located if it has been */ -/* determined to lie in an interval whose width is ABSTOL or */ -/* less. If ABSTOL is less than or equal to zero, then ULP*|T| */ -/* will be used, where |T| means the 1-norm of T. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ - -/* 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. */ - -/* M (output) INTEGER */ -/* The actual number of eigenvalues found. 0 <= M <= N. */ -/* (See also the description of INFO=2,3.) */ - -/* NSPLIT (output) INTEGER */ -/* The number of diagonal blocks in the matrix T. */ -/* 1 <= NSPLIT <= N. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, the first M elements of W will contain the */ -/* eigenvalues. (DSTEBZ may use the remaining N-M elements as */ -/* workspace.) */ - -/* 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. (DSTEBZ may use the remaining N-M elements as */ -/* workspace.) */ - -/* ISPLIT (output) 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.) */ - -/* 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 */ -/* =================== */ - -/* RELFAC DOUBLE PRECISION, default = 2.0e0 */ -/* The relative tolerance. An interval (a,b] lies within */ -/* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), */ -/* where "ulp" is the machine precision (distance from 1 to */ -/* the next larger floating point number.) */ - -/* 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. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --iwork; - --work; - --isplit; - --iblock; - --w; - --e; - --d__; - - /* 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; - } - -/* Decode ORDER */ - - if (lsame_(order, "B")) { - iorder = 2; - } else if (lsame_(order, "E")) { - iorder = 1; - } else { - iorder = 0; - } - -/* Check for Errors */ - - if (irange <= 0) { - *info = -1; - } else if (iorder <= 0) { - *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) { - i__1 = -(*info); - xerbla_("DSTEBZ", &i__1); - return 0; - } - -/* Initialize error flags */ - - *info = 0; - ncnvrg = FALSE_; - toofew = FALSE_; - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - -/* Simplifications: */ - - if (irange == 3 && *il == 1 && *iu == *n) { - irange = 1; - } - -/* Get machine constants */ -/* NB is the minimum vector length for vector bisection, or 0 */ -/* if only scalar is to be done. */ - - safemn = dlamch_("S"); - ulp = dlamch_("P"); - rtoli = ulp * 2.; - nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1); - if (nb <= 1) { - nb = 0; - } - -/* Special Case when N=1 */ - - if (*n == 1) { - *nsplit = 1; - isplit[1] = 1; - if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) { - *m = 0; - } else { - w[1] = d__[1]; - iblock[1] = 1; - *m = 1; - } - return 0; - } - -/* Compute Splitting Points */ - - *nsplit = 1; - work[*n] = 0.; - pivmin = 1.; - -/* DIR$ NOVECTOR */ - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing 2nd power */ - d__1 = e[j - 1]; - tmp1 = d__1 * d__1; -/* Computing 2nd power */ - d__2 = ulp; - if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn - > tmp1) { - isplit[*nsplit] = j - 1; - ++(*nsplit); - work[j - 1] = 0.; - } else { - work[j - 1] = tmp1; - pivmin = max(pivmin,tmp1); - } -/* L10: */ - } - isplit[*nsplit] = *n; - pivmin *= safemn; - -/* Compute Interval and ATOLI */ - - if (irange == 3) { - -/* RANGE='I': Compute the interval containing eigenvalues */ -/* IL through IU. */ - -/* Compute Gershgorin interval for entire (split) matrix */ -/* and use it as the initial interval */ - - gu = d__[1]; - gl = d__[1]; - tmp1 = 0.; - - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - tmp2 = sqrt(work[j]); -/* Computing MAX */ - d__1 = gu, d__2 = d__[j] + tmp1 + tmp2; - gu = max(d__1,d__2); -/* Computing MIN */ - d__1 = gl, d__2 = d__[j] - tmp1 - tmp2; - gl = min(d__1,d__2); - tmp1 = tmp2; -/* L20: */ - } - -/* Computing MAX */ - d__1 = gu, d__2 = d__[*n] + tmp1; - gu = max(d__1,d__2); -/* Computing MIN */ - d__1 = gl, d__2 = d__[*n] - tmp1; - gl = min(d__1,d__2); -/* Computing MAX */ - d__1 = abs(gl), d__2 = abs(gu); - tnorm = max(d__1,d__2); - gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002; - gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1; - -/* Compute Iteration parameters */ - - itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2; - if (*abstol <= 0.) { - atoli = ulp * tnorm; - } else { - atoli = *abstol; - } - - 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], &work[1], &iwork[5], &work[*n + 1], &work[*n - + 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo); - - 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]; - } - - if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) { - *info = 4; - return 0; - } - } else { - -/* RANGE='A' or 'V' -- Set ATOLI */ - -/* Computing MAX */ - d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + ( - d__2 = e[*n - 1], abs(d__2)); - tnorm = max(d__3,d__4); - - i__1 = *n - 1; - for (j = 2; j <= i__1; ++j) { -/* Computing MAX */ - d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1] - , abs(d__2)) + (d__3 = e[j], abs(d__3)); - tnorm = max(d__4,d__5); -/* L30: */ - } - - if (*abstol <= 0.) { - atoli = ulp * tnorm; - } else { - atoli = *abstol; - } - - if (irange == 2) { - wl = *vl; - wu = *vu; - } else { - wl = 0.; - wu = 0.; - } - } - -/* 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 (jb = 1; jb <= i__1; ++jb) { - ioff = iend; - ibegin = ioff + 1; - iend = isplit[jb]; - in = iend - ioff; - - if (in == 1) { - -/* Special Case -- IN=1 */ - - if (irange == 1 || wl >= d__[ibegin] - pivmin) { - ++nwl; - } - if (irange == 1 || wu >= d__[ibegin] - pivmin) { - ++nwu; - } - if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin] - - pivmin) { - ++(*m); - w[*m] = d__[ibegin]; - iblock[*m] = jb; - } - } else { - -/* General Case -- IN > 1 */ - -/* Compute Gershgorin Interval */ -/* and use it as the initial interval */ - - gu = d__[ibegin]; - gl = d__[ibegin]; - tmp1 = 0.; - - i__2 = iend - 1; - for (j = ibegin; j <= i__2; ++j) { - tmp2 = (d__1 = e[j], abs(d__1)); -/* Computing MAX */ - d__1 = gu, d__2 = d__[j] + tmp1 + tmp2; - gu = max(d__1,d__2); -/* Computing MIN */ - d__1 = gl, d__2 = d__[j] - tmp1 - tmp2; - gl = min(d__1,d__2); - tmp1 = tmp2; -/* L40: */ - } - -/* Computing MAX */ - d__1 = gu, d__2 = d__[iend] + tmp1; - gu = max(d__1,d__2); -/* Computing MIN */ - d__1 = gl, d__2 = d__[iend] - tmp1; - gl = min(d__1,d__2); -/* Computing MAX */ - d__1 = abs(gl), d__2 = abs(gu); - bnorm = max(d__1,d__2); - gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1; - gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1; - -/* Compute ATOLI for the current submatrix */ - - if (*abstol <= 0.) { -/* Computing MAX */ - d__1 = abs(gl), d__2 = abs(gu); - atoli = ulp * max(d__1,d__2); - } else { - atoli = *abstol; - } - - if (irange > 1) { - if (gu < wl) { - nwl += in; - nwu += in; - goto L70; - } - gl = max(gl,wl); - gu = min(gu,wu); - if (gl >= gu) { - goto L70; - } - } - -/* Set Up Initial Interval */ - - 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], &work[ibegin], idumma, & - work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], & - w[*m + 1], &iblock[*m + 1], &iinfo); - - 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], &work[ibegin], idumma, & - work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], - &w[*m + 1], &iblock[*m + 1], &iinfo); - -/* Copy Eigenvalues Into W and IBLOCK */ -/* Use -JB for block number for unconverged eigenvalues. */ - - i__2 = iout; - for (j = 1; j <= i__2; ++j) { - tmp1 = (work[j + *n] + work[j + in + *n]) * .5; - -/* Flag non-convergence. */ - - if (j > iout - iinfo) { - ncnvrg = TRUE_; - ib = -jb; - } else { - ib = jb; - } - i__3 = iwork[j + in] + iwoff; - for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) { - w[je] = tmp1; - 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) { - im = 0; - idiscl = *il - 1 - nwl; - idiscu = nwu - *iu; - - if (idiscl > 0 || idiscu > 0) { - i__1 = *m; - for (je = 1; je <= i__1; ++je) { - if (w[je] <= wlu && idiscl > 0) { - --idiscl; - } else if (w[je] >= wul && idiscu > 0) { - --idiscu; - } else { - ++im; - w[im] = w[je]; - iblock[im] = iblock[je]; - } -/* L80: */ - } - *m = im; - } - if (idiscl > 0 || idiscu > 0) { - -/* Code to deal with effects of bad arithmetic: */ -/* 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 simply finding the smallest/largest */ -/* eigenvalue(s). */ - -/* (If N(w) is monotone non-decreasing, this should never */ -/* happen.) */ - - 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: */ - } - } - im = 0; - i__1 = *m; - for (je = 1; je <= i__1; ++je) { - if (iblock[je] != 0) { - ++im; - w[im] = w[je]; - iblock[im] = iblock[je]; - } -/* L130: */ - } - *m = im; - } - if (idiscl < 0 || idiscu < 0) { - 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 (iorder == 1 && *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) { - itmp1 = iblock[ie]; - w[ie] = w[je]; - iblock[ie] = iblock[je]; - w[je] = tmp1; - iblock[je] = itmp1; - } -/* L150: */ - } - } - - *info = 0; - if (ncnvrg) { - ++(*info); - } - if (toofew) { - *info += 2; - } - return 0; - -/* End of DSTEBZ */ - -} /* dstebz_ */ diff --git a/3rdparty/lapack/dstein.c b/3rdparty/lapack/dstein.c deleted file mode 100644 index c2f047e..0000000 --- a/3rdparty/lapack/dstein.c +++ /dev/null @@ -1,452 +0,0 @@ -/* dstein.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 integer c_n1 = -1; - -/* Subroutine */ int dstein_(integer *n, doublereal *d__, doublereal *e, - integer *m, doublereal *w, integer *iblock, integer *isplit, - doublereal *z__, integer *ldz, doublereal *work, integer *iwork, - integer *ifail, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2, i__3; - doublereal d__1, d__2, d__3, d__4, d__5; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, b1, j1, bn; - doublereal xj, scl, eps, sep, nrm, tol; - integer its; - doublereal xjm, ztr, eps1; - integer jblk, nblk; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - integer jmax; - extern doublereal dnrm2_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - integer iseed[4], gpind, iinfo; - extern doublereal dasum_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), daxpy_(integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *); - doublereal ortol; - integer indrv1, indrv2, indrv3, indrv4, indrv5; - extern doublereal dlamch_(char *); - extern /* Subroutine */ int dlagtf_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer * -, integer *); - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *), dlagts_( - integer *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, doublereal *, integer *); - integer nrmchk; - extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *, - doublereal *); - integer blksiz; - doublereal onenrm, dtpcrt, pertol; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEIN computes the eigenvectors of a real symmetric tridiagonal */ -/* matrix T corresponding to specified eigenvalues, using inverse */ -/* iteration. */ - -/* The maximum number of iterations allowed for each eigenvector is */ -/* specified by an internal parameter MAXITS (currently set to 5). */ - -/* 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) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the tridiagonal matrix */ -/* T, in elements 1 to N-1. */ - -/* M (input) INTEGER */ -/* The number of eigenvectors to be found. 0 <= M <= N. */ - -/* W (input) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements of W contain the 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 DSTEBZ with ORDER = 'B' is expected here. ) */ - -/* IBLOCK (input) INTEGER array, dimension (N) */ -/* The submatrix indices associated with the corresponding */ -/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */ -/* the first submatrix from the top, =2 if W(i) belongs to */ -/* the second submatrix, etc. ( The output array IBLOCK */ -/* from DSTEBZ is expected here. ) */ - -/* 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. */ -/* ( The output array ISPLIT from DSTEBZ is expected here. ) */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, M) */ -/* The computed eigenvectors. The eigenvector associated */ -/* with the eigenvalue W(i) is stored in the i-th column of */ -/* Z. Any vector which fails to converge is set to its current */ -/* iterate after MAXITS iterations. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* IFAIL (output) INTEGER array, dimension (M) */ -/* On normal exit, all elements of IFAIL are zero. */ -/* If one or more eigenvectors fail to converge after */ -/* MAXITS iterations, then their indices are stored in */ -/* array IFAIL. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, then i eigenvectors failed to converge */ -/* in MAXITS iterations. Their indices are stored in */ -/* array IFAIL. */ - -/* Internal Parameters */ -/* =================== */ - -/* MAXITS INTEGER, default = 5 */ -/* The maximum number of iterations performed. */ - -/* EXTRA INTEGER, default = 2 */ -/* The number of iterations performed after norm growth */ -/* criterion is satisfied, should be at least 1. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --w; - --iblock; - --isplit; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - *info = 0; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - ifail[i__] = 0; -/* L10: */ - } - - if (*n < 0) { - *info = -1; - } else if (*m < 0 || *m > *n) { - *info = -4; - } else if (*ldz < max(1,*n)) { - *info = -9; - } else { - i__1 = *m; - for (j = 2; j <= i__1; ++j) { - if (iblock[j] < iblock[j - 1]) { - *info = -6; - goto L30; - } - if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { - *info = -5; - goto L30; - } -/* L20: */ - } -L30: - ; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEIN", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *m == 0) { - return 0; - } else if (*n == 1) { - z__[z_dim1 + 1] = 1.; - return 0; - } - -/* Get machine constants. */ - - eps = dlamch_("Precision"); - -/* Initialize seed for random number generator DLARNV. */ - - for (i__ = 1; i__ <= 4; ++i__) { - iseed[i__ - 1] = 1; -/* L40: */ - } - -/* Initialize pointers. */ - - indrv1 = 0; - indrv2 = indrv1 + *n; - indrv3 = indrv2 + *n; - indrv4 = indrv3 + *n; - indrv5 = indrv4 + *n; - -/* Compute eigenvectors of matrix blocks. */ - - j1 = 1; - i__1 = iblock[*m]; - for (nblk = 1; nblk <= i__1; ++nblk) { - -/* Find starting and ending indices of block nblk. */ - - if (nblk == 1) { - b1 = 1; - } else { - b1 = isplit[nblk - 1] + 1; - } - bn = isplit[nblk]; - blksiz = bn - b1 + 1; - if (blksiz == 1) { - goto L60; - } - gpind = b1; - -/* Compute reorthogonalization criterion and stopping criterion. */ - - onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 = e[b1], abs(d__2)); -/* Computing MAX */ - d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1], - abs(d__2)); - onenrm = max(d__3,d__4); - i__2 = bn - 1; - for (i__ = b1 + 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[ - i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3)); - onenrm = max(d__4,d__5); -/* L50: */ - } - ortol = onenrm * .001; - - dtpcrt = sqrt(.1 / blksiz); - -/* Loop through eigenvalues of block nblk. */ - -L60: - jblk = 0; - i__2 = *m; - for (j = j1; j <= i__2; ++j) { - if (iblock[j] != nblk) { - j1 = j; - goto L160; - } - ++jblk; - xj = w[j]; - -/* Skip all the work if the block size is one. */ - - if (blksiz == 1) { - work[indrv1 + 1] = 1.; - goto L120; - } - -/* If eigenvalues j and j-1 are too close, add a relatively */ -/* small perturbation. */ - - if (jblk > 1) { - eps1 = (d__1 = eps * xj, abs(d__1)); - pertol = eps1 * 10.; - sep = xj - xjm; - if (sep < pertol) { - xj = xjm + pertol; - } - } - - its = 0; - nrmchk = 0; - -/* Get random starting vector. */ - - dlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]); - -/* Copy the matrix T so it won't be destroyed in factorization. */ - - dcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1); - i__3 = blksiz - 1; - dcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1); - i__3 = blksiz - 1; - dcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1); - -/* Compute LU factors with partial pivoting ( PT = LU ) */ - - tol = 0.; - dlagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[ - indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo); - -/* Update iteration count. */ - -L70: - ++its; - if (its > 5) { - goto L100; - } - -/* Normalize and scale the righthand side vector Pb. */ - -/* Computing MAX */ - d__2 = eps, d__3 = (d__1 = work[indrv4 + blksiz], abs(d__1)); - scl = blksiz * onenrm * max(d__2,d__3) / dasum_(&blksiz, &work[ - indrv1 + 1], &c__1); - dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); - -/* Solve the system LU = Pb. */ - - dlagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], & - work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[ - indrv1 + 1], &tol, &iinfo); - -/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */ -/* close enough. */ - - if (jblk == 1) { - goto L90; - } - if ((d__1 = xj - xjm, abs(d__1)) > ortol) { - gpind = j; - } - if (gpind != j) { - i__3 = j - 1; - for (i__ = gpind; i__ <= i__3; ++i__) { - ztr = -ddot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 + - i__ * z_dim1], &c__1); - daxpy_(&blksiz, &ztr, &z__[b1 + i__ * z_dim1], &c__1, & - work[indrv1 + 1], &c__1); -/* L80: */ - } - } - -/* Check the infinity norm of the iterate. */ - -L90: - jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); - nrm = (d__1 = work[indrv1 + jmax], abs(d__1)); - -/* Continue for additional iterations after norm reaches */ -/* stopping criterion. */ - - if (nrm < dtpcrt) { - goto L70; - } - ++nrmchk; - if (nrmchk < 3) { - goto L70; - } - - goto L110; - -/* If stopping criterion was not satisfied, update info and */ -/* store eigenvector number in array ifail. */ - -L100: - ++(*info); - ifail[*info] = j; - -/* Accept iterate as jth eigenvector. */ - -L110: - scl = 1. / dnrm2_(&blksiz, &work[indrv1 + 1], &c__1); - jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); - if (work[indrv1 + jmax] < 0.) { - scl = -scl; - } - dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); -L120: - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - z__[i__ + j * z_dim1] = 0.; -/* L130: */ - } - i__3 = blksiz; - for (i__ = 1; i__ <= i__3; ++i__) { - z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__]; -/* L140: */ - } - -/* Save the shift to check eigenvalue spacing at next */ -/* iteration. */ - - xjm = xj; - -/* L150: */ - } -L160: - ; - } - - return 0; - -/* End of DSTEIN */ - -} /* dstein_ */ diff --git a/3rdparty/lapack/dstemr.c b/3rdparty/lapack/dstemr.c deleted file mode 100644 index dc34245..0000000 --- a/3rdparty/lapack/dstemr.c +++ /dev/null @@ -1,728 +0,0 @@ -/* dstemr.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_b18 = .001; - -/* Subroutine */ int dstemr_(char *jobz, char *range, integer *n, doublereal * - d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, - integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz, - integer *nzc, integer *isuppz, logical *tryrac, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - doublereal d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j; - doublereal r1, r2; - integer jj; - doublereal cs; - integer in; - doublereal sn, wl, wu; - integer iil, iiu; - doublereal eps, tmp; - integer indd, iend, jblk, wend; - doublereal rmin, rmax; - integer itmp; - doublereal tnrm; - extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *); - integer inde2, itmp2; - doublereal rtol1, rtol2; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - doublereal scale; - integer indgp; - extern logical lsame_(char *, char *); - integer iinfo, iindw, ilast; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dswap_(integer *, doublereal *, integer - *, doublereal *, integer *); - integer lwmin; - logical wantz; - extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *); - extern doublereal dlamch_(char *); - logical alleig; - integer ibegin; - logical indeig; - integer iindbl; - logical valeig; - extern /* Subroutine */ int dlarrc_(char *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *, integer *, integer *), dlarre_(char *, - integer *, doublereal *, doublereal *, integer *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *, integer *); - integer wbegin; - doublereal safmin; - extern /* Subroutine */ int dlarrj_(integer *, doublereal *, doublereal *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *), xerbla_(char *, integer *); - doublereal bignum; - integer inderr, iindwk, indgrs, offset; - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); - extern /* Subroutine */ int dlarrr_(integer *, doublereal *, doublereal *, - integer *), dlarrv_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, integer *, integer *, - integer *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *), dlasrt_(char *, integer *, doublereal *, - integer *); - doublereal thresh; - integer iinspl, ifirst, indwrk, liwmin, nzcmin; - doublereal pivmin; - integer nsplit; - doublereal smlnum; - logical lquery, zquery; - - -/* -- LAPACK computational routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEMR computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ -/* a well defined set of pairwise different real eigenvalues, the corresponding */ -/* real eigenvectors are pairwise orthogonal. */ - -/* The spectrum may be computed either completely or partially by specifying */ -/* either an interval (VL,VU] or a range of indices IL:IU for the desired */ -/* eigenvalues. */ - -/* Depending on the number of desired eigenvalues, these are computed either */ -/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */ -/* computed by the use of various suitable L D L^T factorizations near clusters */ -/* of close eigenvalues (referred to as RRRs, Relatively Robust */ -/* Representations). An informal sketch of the algorithm follows. */ - -/* For each unreduced block (submatrix) of T, */ -/* (a) Compute T - sigma I = L D L^T, so that L and D */ -/* define all the wanted eigenvalues to high relative accuracy. */ -/* This means that small relative changes in the entries of D and L */ -/* cause only small relative changes in the eigenvalues and */ -/* eigenvectors. The standard (unfactored) representation of the */ -/* tridiagonal matrix T does not have this property in general. */ -/* (b) Compute the eigenvalues to suitable accuracy. */ -/* If the eigenvectors are desired, the algorithm attains full */ -/* accuracy of the computed eigenvalues only right before */ -/* the corresponding vectors have to be computed, see steps c) and d). */ -/* (c) For each cluster of close eigenvalues, select a new */ -/* shift close to the cluster, find a new factorization, and refine */ -/* the shifted eigenvalues to suitable accuracy. */ -/* (d) For each eigenvalue with a large enough relative separation compute */ -/* the corresponding eigenvector by forming a rank revealing twisted */ -/* factorization. Go back to (c) for any clusters that remain. */ - -/* For more details, see: */ -/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* 2004. Also LAPACK Working Note 154. */ -/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* tridiagonal eigenvalue/eigenvector problem", */ -/* Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* UC Berkeley, May 1997. */ - -/* Notes: */ -/* 1.DSTEMR works only on machines which follow IEEE-754 */ -/* floating-point standard in their handling of infinities and NaNs. */ -/* This permits the use of efficient inner loops avoiding a check for */ -/* zero divisors. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the N diagonal elements of the tridiagonal matrix */ -/* T. On exit, D is overwritten. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the (N-1) subdiagonal elements of the tridiagonal */ -/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */ -/* input, but is used internally as workspace. */ -/* On exit, E is overwritten. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. 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. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ -/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix T */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and can be computed with a workspace */ -/* query by setting NZC = -1, see below. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', then LDZ >= max(1,N). */ - -/* NZC (input) INTEGER */ -/* The number of eigenvectors to be held in the array Z. */ -/* If RANGE = 'A', then NZC >= max(1,N). */ -/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */ -/* If RANGE = 'I', then NZC >= IU-IL+1. */ -/* If NZC = -1, then a workspace query is assumed; the */ -/* routine calculates the number of columns of the array Z that */ -/* are needed to hold the eigenvectors. */ -/* This value is returned as the first entry of the Z array, and */ -/* no error message related to NZC is issued by XERBLA. */ - -/* 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 computed eigenvector */ -/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */ -/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ - -/* TRYRAC (input/output) LOGICAL */ -/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */ -/* the tridiagonal matrix defines its eigenvalues to high relative */ -/* accuracy. If so, the code uses relative-accuracy preserving */ -/* algorithms that might be (a bit) slower depending on the matrix. */ -/* If the matrix does not define its eigenvalues to high relative */ -/* accuracy, the code can uses possibly faster algorithms. */ -/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */ -/* relatively accurate eigenvalues and can use the fastest possible */ -/* techniques. */ -/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */ -/* does not define its eigenvalues to high relative accuracy. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal */ -/* (and minimal) LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,18*N) */ -/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */ -/* 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/output) INTEGER array, dimension (LIWORK) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */ -/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */ -/* if only the eigenvalues are to be computed. */ -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* On exit, INFO */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = 1X, internal error in DLARRE, */ -/* if INFO = 2X, internal error in DLARRV. */ -/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ -/* the nonzero error code returned by DLARRE or */ -/* DLARRV, respectively. */ - - -/* 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 .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - lquery = *lwork == -1 || *liwork == -1; - zquery = *nzc == -1; -/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */ -/* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */ -/* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */ - if (wantz) { - lwmin = *n * 18; - liwmin = *n * 10; - } else { -/* need less workspace if only the eigenvalues are wanted */ - lwmin = *n * 12; - liwmin = *n << 3; - } - wl = 0.; - wu = 0.; - iil = 0; - iiu = 0; - if (valeig) { -/* We do not reference VL, VU in the cases RANGE = 'I','A' */ -/* The interval (WL, WU] contains all the wanted eigenvalues. */ -/* It is either given by the user or computed in DLARRE. */ - wl = *vl; - wu = *vu; - } else if (indeig) { -/* We do not reference IL, IU in the cases RANGE = 'V','A' */ - iil = *il; - iiu = *iu; - } - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (valeig && *n > 0 && wu <= wl) { - *info = -7; - } else if (indeig && (iil < 1 || iil > *n)) { - *info = -8; - } else if (indeig && (iiu < iil || iiu > *n)) { - *info = -9; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -13; - } else if (*lwork < lwmin && ! lquery) { - *info = -17; - } else if (*liwork < liwmin && ! lquery) { - *info = -19; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = min(d__1,d__2); - - if (*info == 0) { - work[1] = (doublereal) lwmin; - iwork[1] = liwmin; - - if (wantz && alleig) { - nzcmin = *n; - } else if (wantz && valeig) { - dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, & - itmp2, info); - } else if (wantz && indeig) { - nzcmin = iiu - iil + 1; - } else { -/* WANTZ .EQ. FALSE. */ - nzcmin = 0; - } - if (zquery && *info == 0) { - z__[z_dim1 + 1] = (doublereal) nzcmin; - } else if (*nzc < nzcmin && ! zquery) { - *info = -14; - } - } - if (*info != 0) { - - i__1 = -(*info); - xerbla_("DSTEMR", &i__1); - - return 0; - } else if (lquery || zquery) { - return 0; - } - -/* Handle N = 0, 1, and 2 cases immediately */ - - *m = 0; - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (alleig || indeig) { - *m = 1; - w[1] = d__[1]; - } else { - if (wl < d__[1] && wu >= d__[1]) { - *m = 1; - w[1] = d__[1]; - } - } - if (wantz && ! zquery) { - z__[z_dim1 + 1] = 1.; - isuppz[1] = 1; - isuppz[2] = 1; - } - return 0; - } - - if (*n == 2) { - if (! wantz) { - dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2); - } else if (wantz && ! zquery) { - dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn); - } - if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) { - ++(*m); - w[*m] = r2; - if (wantz && ! zquery) { - z__[*m * z_dim1 + 1] = -sn; - z__[*m * z_dim1 + 2] = cs; -/* Note: At most one of SN and CS can be zero. */ - if (sn != 0.) { - if (cs != 0.) { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 2; - } else { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 1; - } - } else { - isuppz[(*m << 1) - 1] = 2; - isuppz[*m * 2] = 2; - } - } - } - if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) { - ++(*m); - w[*m] = r1; - if (wantz && ! zquery) { - z__[*m * z_dim1 + 1] = cs; - z__[*m * z_dim1 + 2] = sn; -/* Note: At most one of SN and CS can be zero. */ - if (sn != 0.) { - if (cs != 0.) { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 2; - } else { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 1; - } - } else { - isuppz[(*m << 1) - 1] = 2; - isuppz[*m * 2] = 2; - } - } - } - return 0; - } -/* Continue with general N */ - indgrs = 1; - inderr = (*n << 1) + 1; - indgp = *n * 3 + 1; - indd = (*n << 2) + 1; - inde2 = *n * 5 + 1; - indwrk = *n * 6 + 1; - - iinspl = 1; - iindbl = *n + 1; - iindw = (*n << 1) + 1; - iindwk = *n * 3 + 1; - -/* Scale matrix to allowable range, if necessary. */ -/* The allowable range is related to the PIVMIN parameter; see the */ -/* comments in DLARRD. The preference for scaling small values */ -/* up is heuristic; we expect users' matrices not to be close to the */ -/* RMAX threshold. */ - - scale = 1.; - tnrm = dlanst_("M", n, &d__[1], &e[1]); - if (tnrm > 0. && tnrm < rmin) { - scale = rmin / tnrm; - } else if (tnrm > rmax) { - scale = rmax / tnrm; - } - if (scale != 1.) { - dscal_(n, &scale, &d__[1], &c__1); - i__1 = *n - 1; - dscal_(&i__1, &scale, &e[1], &c__1); - tnrm *= scale; - if (valeig) { -/* If eigenvalues in interval have to be found, */ -/* scale (WL, WU] accordingly */ - wl *= scale; - wu *= scale; - } - } - -/* Compute the desired eigenvalues of the tridiagonal after splitting */ -/* into smaller subblocks if the corresponding off-diagonal elements */ -/* are small */ -/* THRESH is the splitting parameter for DLARRE */ -/* A negative THRESH forces the old splitting criterion based on the */ -/* size of the off-diagonal. A positive THRESH switches to splitting */ -/* which preserves relative accuracy. */ - - if (*tryrac) { -/* Test whether the matrix warrants the more expensive relative approach. */ - dlarrr_(n, &d__[1], &e[1], &iinfo); - } else { -/* The user does not care about relative accurately eigenvalues */ - iinfo = -1; - } -/* Set the splitting criterion */ - if (iinfo == 0) { - thresh = eps; - } else { - thresh = -eps; -/* relative accuracy is desired but T does not guarantee it */ - *tryrac = FALSE_; - } - - if (*tryrac) { -/* Copy original diagonal, needed to guarantee relative accuracy */ - dcopy_(n, &d__[1], &c__1, &work[indd], &c__1); - } -/* Store the squares of the offdiagonal values of T */ - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing 2nd power */ - d__1 = e[j]; - work[inde2 + j - 1] = d__1 * d__1; -/* L5: */ - } -/* Set the tolerance parameters for bisection */ - if (! wantz) { -/* DLARRE computes the eigenvalues to full precision. */ - rtol1 = eps * 4.; - rtol2 = eps * 4.; - } else { -/* DLARRE computes the eigenvalues to less than full precision. */ -/* DLARRV will refine the eigenvalue approximations, and we can */ -/* need less accurate initial bisection in DLARRE. */ -/* Note: these settings do only affect the subset case and DLARRE */ - rtol1 = sqrt(eps); -/* Computing MAX */ - d__1 = sqrt(eps) * .005, d__2 = eps * 4.; - rtol2 = max(d__1,d__2); - } - dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], & - rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[ - inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[ - indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo); - if (iinfo != 0) { - *info = abs(iinfo) + 10; - return 0; - } -/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */ -/* part of the spectrum. All desired eigenvalues are contained in */ -/* (WL,WU] */ - if (wantz) { - -/* Compute the desired eigenvectors corresponding to the computed */ -/* eigenvalues */ - - dlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, & - c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[ - indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[ - z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], & - iinfo); - if (iinfo != 0) { - *info = abs(iinfo) + 20; - return 0; - } - } else { -/* DLARRE computes eigenvalues of the (shifted) root representation */ -/* DLARRV returns the eigenvalues of the unshifted matrix. */ -/* However, if the eigenvectors are not desired by the user, we need */ -/* to apply the corresponding shifts from DLARRE to obtain the */ -/* eigenvalues of the original matrix. */ - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - itmp = iwork[iindbl + j - 1]; - w[j] += e[iwork[iinspl + itmp - 1]]; -/* L20: */ - } - } - - if (*tryrac) { -/* Refine computed eigenvalues so that they are relatively accurate */ -/* with respect to the original matrix T. */ - ibegin = 1; - wbegin = 1; - i__1 = iwork[iindbl + *m - 1]; - for (jblk = 1; jblk <= i__1; ++jblk) { - iend = iwork[iinspl + jblk - 1]; - in = iend - ibegin + 1; - wend = wbegin - 1; -/* check if any eigenvalues have to be refined in this block */ -L36: - if (wend < *m) { - if (iwork[iindbl + wend] == jblk) { - ++wend; - goto L36; - } - } - if (wend < wbegin) { - ibegin = iend + 1; - goto L39; - } - offset = iwork[iindw + wbegin - 1] - 1; - ifirst = iwork[iindw + wbegin - 1]; - ilast = iwork[iindw + wend - 1]; - rtol2 = eps * 4.; - dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1], - &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[ - inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], & - pivmin, &tnrm, &iinfo); - ibegin = iend + 1; - wbegin = wend + 1; -L39: - ; - } - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (scale != 1.) { - d__1 = 1. / scale; - dscal_(m, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in increasing order, then sort them, */ -/* possibly along with eigenvectors. */ - - if (nsplit > 1) { - if (! wantz) { - dlasrt_("I", m, &w[1], &iinfo); - if (iinfo != 0) { - *info = 3; - return 0; - } - } else { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp) { - i__ = jj; - tmp = w[jj]; - } -/* L50: */ - } - if (i__ != 0) { - w[i__] = w[j]; - w[j] = tmp; - if (wantz) { - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * - z_dim1 + 1], &c__1); - itmp = isuppz[(i__ << 1) - 1]; - isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1]; - isuppz[(j << 1) - 1] = itmp; - itmp = isuppz[i__ * 2]; - isuppz[i__ * 2] = isuppz[j * 2]; - isuppz[j * 2] = itmp; - } - } -/* L60: */ - } - } - } - - - work[1] = (doublereal) lwmin; - iwork[1] = liwmin; - return 0; - -/* End of DSTEMR */ - -} /* dstemr_ */ diff --git a/3rdparty/lapack/dsteqr.c b/3rdparty/lapack/dsteqr.c deleted file mode 100644 index 1dc354e..0000000 --- a/3rdparty/lapack/dsteqr.c +++ /dev/null @@ -1,621 +0,0 @@ -/* dsteqr.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_b9 = 0.; -static doublereal c_b10 = 1.; -static integer c__0 = 0; -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - doublereal d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal), d_sign(doublereal *, doublereal *); - - /* Local variables */ - doublereal b, c__, f, g; - integer i__, j, k, l, m; - doublereal p, r__, s; - integer l1, ii, mm, lm1, mm1, nm1; - doublereal rt1, rt2, eps; - integer lsv; - doublereal tst, eps2; - integer lend, jtot; - extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, - integer *, doublereal *, doublereal *, doublereal *, integer *); - doublereal anorm; - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *), dlaev2_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *); - integer lendm1, lendp1; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); - integer iscale; - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *), dlaset_(char *, integer *, integer - *, doublereal *, doublereal *, doublereal *, integer *); - doublereal safmin; - extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); - doublereal safmax; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); - extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, - integer *); - integer lendsv; - doublereal ssfmin; - integer nmaxit, icompz; - doublereal ssfmax; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */ -/* symmetric tridiagonal matrix using the implicit QL or QR method. */ -/* The eigenvectors of a full or band symmetric matrix can also be found */ -/* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */ -/* tridiagonal form. */ - -/* Arguments */ -/* ========= */ - -/* COMPZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only. */ -/* = 'V': Compute eigenvalues and eigenvectors of the original */ -/* symmetric matrix. On entry, Z must contain the */ -/* orthogonal matrix used to reduce the original matrix */ -/* to tridiagonal form. */ -/* = 'I': Compute eigenvalues and eigenvectors of the */ -/* tridiagonal matrix. Z is initialized to the identity */ -/* matrix. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the diagonal elements of the tridiagonal matrix. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix. */ -/* On exit, E has been destroyed. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* On entry, if COMPZ = 'V', then Z contains the orthogonal */ -/* matrix used in the reduction to tridiagonal form. */ -/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ -/* orthonormal eigenvectors of the original symmetric matrix, */ -/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ -/* of the symmetric tridiagonal matrix. */ -/* If COMPZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* eigenvectors are desired, then LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */ -/* If COMPZ = 'N', then WORK is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: the algorithm has failed to find all the eigenvalues in */ -/* a total of 30*N iterations; if INFO = i, then i */ -/* elements of E have not converged to zero; on exit, D */ -/* and E contain the elements of a symmetric tridiagonal */ -/* matrix which is orthogonally similar to the original */ -/* matrix. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - *info = 0; - - if (lsame_(compz, "N")) { - icompz = 0; - } else if (lsame_(compz, "V")) { - icompz = 1; - } else if (lsame_(compz, "I")) { - icompz = 2; - } else { - icompz = -1; - } - if (icompz < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEQR", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (icompz == 2) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Determine the unit roundoff and over/underflow thresholds. */ - - eps = dlamch_("E"); -/* Computing 2nd power */ - d__1 = eps; - eps2 = d__1 * d__1; - safmin = dlamch_("S"); - safmax = 1. / safmin; - ssfmax = sqrt(safmax) / 3.; - ssfmin = sqrt(safmin) / eps2; - -/* Compute the eigenvalues and eigenvectors of the tridiagonal */ -/* matrix. */ - - if (icompz == 2) { - dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz); - } - - nmaxit = *n * 30; - jtot = 0; - -/* Determine where the matrix splits and choose QL or QR iteration */ -/* for each block, according to whether top or bottom diagonal */ -/* element is smaller. */ - - l1 = 1; - nm1 = *n - 1; - -L10: - if (l1 > *n) { - goto L160; - } - if (l1 > 1) { - e[l1 - 1] = 0.; - } - if (l1 <= nm1) { - i__1 = nm1; - for (m = l1; m <= i__1; ++m) { - tst = (d__1 = e[m], abs(d__1)); - if (tst == 0.) { - goto L30; - } - if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m - + 1], abs(d__2))) * eps) { - e[m] = 0.; - goto L30; - } -/* L20: */ - } - } - m = *n; - -L30: - l = l1; - lsv = l; - lend = m; - lendsv = lend; - l1 = m + 1; - if (lend == l) { - goto L10; - } - -/* Scale submatrix in rows and columns L to LEND */ - - i__1 = lend - l + 1; - anorm = dlanst_("I", &i__1, &d__[l], &e[l]); - iscale = 0; - if (anorm == 0.) { - goto L10; - } - if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info); - } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info); - } - -/* Choose between QL and QR iteration */ - - if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { - lend = lsv; - l = lendsv; - } - - if (lend > l) { - -/* QL Iteration */ - -/* Look for small subdiagonal element. */ - -L40: - if (l != lend) { - lendm1 = lend - 1; - i__1 = lendm1; - for (m = l; m <= i__1; ++m) { -/* Computing 2nd power */ - d__2 = (d__1 = e[m], abs(d__1)); - tst = d__2 * d__2; - if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - + 1], abs(d__2)) + safmin) { - goto L60; - } -/* L50: */ - } - } - - m = lend; - -L60: - if (m < lend) { - e[m] = 0.; - } - p = d__[l]; - if (m == l) { - goto L80; - } - -/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ -/* to compute its eigensystem. */ - - if (m == l + 1) { - if (icompz > 0) { - dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); - work[l] = c__; - work[*n - 1 + l] = s; - dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & - z__[l * z_dim1 + 1], ldz); - } else { - dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); - } - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.; - l += 2; - if (l <= lend) { - goto L40; - } - goto L140; - } - - if (jtot == nmaxit) { - goto L140; - } - ++jtot; - -/* Form shift. */ - - g = (d__[l + 1] - p) / (e[l] * 2.); - r__ = dlapy2_(&g, &c_b10); - g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); - - s = 1.; - c__ = 1.; - p = 0.; - -/* Inner loop */ - - mm1 = m - 1; - i__1 = l; - for (i__ = mm1; i__ >= i__1; --i__) { - f = s * e[i__]; - b = c__ * e[i__]; - dlartg_(&g, &f, &c__, &s, &r__); - if (i__ != m - 1) { - e[i__ + 1] = r__; - } - g = d__[i__ + 1] - p; - r__ = (d__[i__] - g) * s + c__ * 2. * b; - p = s * r__; - d__[i__ + 1] = g + p; - g = c__ * r__ - b; - -/* If eigenvectors are desired, then save rotations. */ - - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = -s; - } - -/* L70: */ - } - -/* If eigenvectors are desired, then apply saved rotations. */ - - if (icompz > 0) { - mm = m - l + 1; - dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l - * z_dim1 + 1], ldz); - } - - d__[l] -= p; - e[l] = g; - goto L40; - -/* Eigenvalue found. */ - -L80: - d__[l] = p; - - ++l; - if (l <= lend) { - goto L40; - } - goto L140; - - } else { - -/* QR Iteration */ - -/* Look for small superdiagonal element. */ - -L90: - if (l != lend) { - lendp1 = lend + 1; - i__1 = lendp1; - for (m = l; m >= i__1; --m) { -/* Computing 2nd power */ - d__2 = (d__1 = e[m - 1], abs(d__1)); - tst = d__2 * d__2; - if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - - 1], abs(d__2)) + safmin) { - goto L110; - } -/* L100: */ - } - } - - m = lend; - -L110: - if (m > lend) { - e[m - 1] = 0.; - } - p = d__[l]; - if (m == l) { - goto L130; - } - -/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ -/* to compute its eigensystem. */ - - if (m == l - 1) { - if (icompz > 0) { - dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) - ; - work[m] = c__; - work[*n - 1 + m] = s; - dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & - z__[(l - 1) * z_dim1 + 1], ldz); - } else { - dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); - } - d__[l - 1] = rt1; - d__[l] = rt2; - e[l - 1] = 0.; - l += -2; - if (l >= lend) { - goto L90; - } - goto L140; - } - - if (jtot == nmaxit) { - goto L140; - } - ++jtot; - -/* Form shift. */ - - g = (d__[l - 1] - p) / (e[l - 1] * 2.); - r__ = dlapy2_(&g, &c_b10); - g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); - - s = 1.; - c__ = 1.; - p = 0.; - -/* Inner loop */ - - lm1 = l - 1; - i__1 = lm1; - for (i__ = m; i__ <= i__1; ++i__) { - f = s * e[i__]; - b = c__ * e[i__]; - dlartg_(&g, &f, &c__, &s, &r__); - if (i__ != m) { - e[i__ - 1] = r__; - } - g = d__[i__] - p; - r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; - p = s * r__; - d__[i__] = g + p; - g = c__ * r__ - b; - -/* If eigenvectors are desired, then save rotations. */ - - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = s; - } - -/* L120: */ - } - -/* If eigenvectors are desired, then apply saved rotations. */ - - if (icompz > 0) { - mm = l - m + 1; - dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m - * z_dim1 + 1], ldz); - } - - d__[l] -= p; - e[lm1] = g; - goto L90; - -/* Eigenvalue found. */ - -L130: - d__[l] = p; - - --l; - if (l >= lend) { - goto L90; - } - goto L140; - - } - -/* Undo scaling if necessary */ - -L140: - if (iscale == 1) { - i__1 = lendsv - lsv + 1; - dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - i__1 = lendsv - lsv; - dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, - info); - } else if (iscale == 2) { - i__1 = lendsv - lsv + 1; - dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - i__1 = lendsv - lsv; - dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, - info); - } - -/* Check for no convergence to an eigenvalue after a total */ -/* of N*MAXIT iterations. */ - - if (jtot < nmaxit) { - goto L10; - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } -/* L150: */ - } - goto L190; - -/* Order eigenvalues and eigenvectors. */ - -L160: - if (icompz == 0) { - -/* Use Quick Sort */ - - dlasrt_("I", n, &d__[1], info); - - } else { - -/* Use Selection Sort to minimize swaps of eigenvectors */ - - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - k = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] < p) { - k = j; - p = d__[j]; - } -/* L170: */ - } - if (k != i__) { - d__[k] = d__[i__]; - d__[i__] = p; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], - &c__1); - } -/* L180: */ - } - } - -L190: - return 0; - -/* End of DSTEQR */ - -} /* dsteqr_ */ diff --git a/3rdparty/lapack/dsterf.c b/3rdparty/lapack/dsterf.c deleted file mode 100644 index ea66b97..0000000 --- a/3rdparty/lapack/dsterf.c +++ /dev/null @@ -1,461 +0,0 @@ -/* dsterf.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__1 = 1; -static doublereal c_b32 = 1.; - -/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e, - integer *info) -{ - /* System generated locals */ - integer i__1; - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal), d_sign(doublereal *, doublereal *); - - /* Local variables */ - doublereal c__; - integer i__, l, m; - doublereal p, r__, s; - integer l1; - doublereal bb, rt1, rt2, eps, rte; - integer lsv; - doublereal eps2, oldc; - integer lend, jtot; - extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *); - doublereal gamma, alpha, sigma, anorm; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); - integer iscale; - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *); - doublereal oldgam, safmin; - extern /* Subroutine */ int xerbla_(char *, integer *); - doublereal safmax; - extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); - extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, - integer *); - integer lendsv; - doublereal ssfmin; - integer nmaxit; - doublereal ssfmax; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix */ -/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix. */ -/* On exit, E has been destroyed. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: the algorithm failed to find all of the eigenvalues in */ -/* a total of 30*N iterations; if INFO = i, then i */ -/* elements of E have not converged to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --e; - --d__; - - /* Function Body */ - *info = 0; - -/* Quick return if possible */ - - if (*n < 0) { - *info = -1; - i__1 = -(*info); - xerbla_("DSTERF", &i__1); - return 0; - } - if (*n <= 1) { - return 0; - } - -/* Determine the unit roundoff for this environment. */ - - eps = dlamch_("E"); -/* Computing 2nd power */ - d__1 = eps; - eps2 = d__1 * d__1; - safmin = dlamch_("S"); - safmax = 1. / safmin; - ssfmax = sqrt(safmax) / 3.; - ssfmin = sqrt(safmin) / eps2; - -/* Compute the eigenvalues of the tridiagonal matrix. */ - - nmaxit = *n * 30; - sigma = 0.; - jtot = 0; - -/* Determine where the matrix splits and choose QL or QR iteration */ -/* for each block, according to whether top or bottom diagonal */ -/* element is smaller. */ - - l1 = 1; - -L10: - if (l1 > *n) { - goto L170; - } - if (l1 > 1) { - e[l1 - 1] = 0.; - } - i__1 = *n - 1; - for (m = l1; m <= i__1; ++m) { - if ((d__3 = e[m], abs(d__3)) <= sqrt((d__1 = d__[m], abs(d__1))) * - sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { - e[m] = 0.; - goto L30; - } -/* L20: */ - } - m = *n; - -L30: - l = l1; - lsv = l; - lend = m; - lendsv = lend; - l1 = m + 1; - if (lend == l) { - goto L10; - } - -/* Scale submatrix in rows and columns L to LEND */ - - i__1 = lend - l + 1; - anorm = dlanst_("I", &i__1, &d__[l], &e[l]); - iscale = 0; - if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info); - } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info); - } - - i__1 = lend - 1; - for (i__ = l; i__ <= i__1; ++i__) { -/* Computing 2nd power */ - d__1 = e[i__]; - e[i__] = d__1 * d__1; -/* L40: */ - } - -/* Choose between QL and QR iteration */ - - if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { - lend = lsv; - l = lendsv; - } - - if (lend >= l) { - -/* QL Iteration */ - -/* Look for small subdiagonal element. */ - -L50: - if (l != lend) { - i__1 = lend - 1; - for (m = l; m <= i__1; ++m) { - if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m - + 1], abs(d__1))) { - goto L70; - } -/* L60: */ - } - } - m = lend; - -L70: - if (m < lend) { - e[m] = 0.; - } - p = d__[l]; - if (m == l) { - goto L90; - } - -/* If remaining matrix is 2 by 2, use DLAE2 to compute its */ -/* eigenvalues. */ - - if (m == l + 1) { - rte = sqrt(e[l]); - dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.; - l += 2; - if (l <= lend) { - goto L50; - } - goto L150; - } - - if (jtot == nmaxit) { - goto L150; - } - ++jtot; - -/* Form shift. */ - - rte = sqrt(e[l]); - sigma = (d__[l + 1] - p) / (rte * 2.); - r__ = dlapy2_(&sigma, &c_b32); - sigma = p - rte / (sigma + d_sign(&r__, &sigma)); - - c__ = 1.; - s = 0.; - gamma = d__[m] - sigma; - p = gamma * gamma; - -/* Inner loop */ - - i__1 = l; - for (i__ = m - 1; i__ >= i__1; --i__) { - bb = e[i__]; - r__ = p + bb; - if (i__ != m - 1) { - e[i__ + 1] = s * r__; - } - oldc = c__; - c__ = p / r__; - s = bb / r__; - oldgam = gamma; - alpha = d__[i__]; - gamma = c__ * (alpha - sigma) - s * oldgam; - d__[i__ + 1] = oldgam + (alpha - gamma); - if (c__ != 0.) { - p = gamma * gamma / c__; - } else { - p = oldc * bb; - } -/* L80: */ - } - - e[l] = s * p; - d__[l] = sigma + gamma; - goto L50; - -/* Eigenvalue found. */ - -L90: - d__[l] = p; - - ++l; - if (l <= lend) { - goto L50; - } - goto L150; - - } else { - -/* QR Iteration */ - -/* Look for small superdiagonal element. */ - -L100: - i__1 = lend + 1; - for (m = l; m >= i__1; --m) { - if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m - - 1], abs(d__1))) { - goto L120; - } -/* L110: */ - } - m = lend; - -L120: - if (m > lend) { - e[m - 1] = 0.; - } - p = d__[l]; - if (m == l) { - goto L140; - } - -/* If remaining matrix is 2 by 2, use DLAE2 to compute its */ -/* eigenvalues. */ - - if (m == l - 1) { - rte = sqrt(e[l - 1]); - dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); - d__[l] = rt1; - d__[l - 1] = rt2; - e[l - 1] = 0.; - l += -2; - if (l >= lend) { - goto L100; - } - goto L150; - } - - if (jtot == nmaxit) { - goto L150; - } - ++jtot; - -/* Form shift. */ - - rte = sqrt(e[l - 1]); - sigma = (d__[l - 1] - p) / (rte * 2.); - r__ = dlapy2_(&sigma, &c_b32); - sigma = p - rte / (sigma + d_sign(&r__, &sigma)); - - c__ = 1.; - s = 0.; - gamma = d__[m] - sigma; - p = gamma * gamma; - -/* Inner loop */ - - i__1 = l - 1; - for (i__ = m; i__ <= i__1; ++i__) { - bb = e[i__]; - r__ = p + bb; - if (i__ != m) { - e[i__ - 1] = s * r__; - } - oldc = c__; - c__ = p / r__; - s = bb / r__; - oldgam = gamma; - alpha = d__[i__ + 1]; - gamma = c__ * (alpha - sigma) - s * oldgam; - d__[i__] = oldgam + (alpha - gamma); - if (c__ != 0.) { - p = gamma * gamma / c__; - } else { - p = oldc * bb; - } -/* L130: */ - } - - e[l - 1] = s * p; - d__[l] = sigma + gamma; - goto L100; - -/* Eigenvalue found. */ - -L140: - d__[l] = p; - - --l; - if (l >= lend) { - goto L100; - } - goto L150; - - } - -/* Undo scaling if necessary */ - -L150: - if (iscale == 1) { - i__1 = lendsv - lsv + 1; - dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - } - if (iscale == 2) { - i__1 = lendsv - lsv + 1; - dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - } - -/* Check for no convergence to an eigenvalue after a total */ -/* of N*MAXIT iterations. */ - - if (jtot < nmaxit) { - goto L10; - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } -/* L160: */ - } - goto L180; - -/* Sort eigenvalues in increasing order. */ - -L170: - dlasrt_("I", n, &d__[1], info); - -L180: - return 0; - -/* End of DSTERF */ - -} /* dsterf_ */ diff --git a/3rdparty/lapack/dswap.c b/3rdparty/lapack/dswap.c deleted file mode 100644 index 2e29260..0000000 --- a/3rdparty/lapack/dswap.c +++ /dev/null @@ -1,114 +0,0 @@ -/* dswap.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 dswap_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - doublereal dtemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* interchanges two vectors. */ -/* uses unrolled loops for increments equal 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__) { - dtemp = dx[ix]; - dx[ix] = dy[iy]; - dy[iy] = dtemp; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 3; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = dx[i__]; - dx[i__] = dy[i__]; - dy[i__] = dtemp; -/* L30: */ - } - if (*n < 3) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 3) { - dtemp = dx[i__]; - dx[i__] = dy[i__]; - dy[i__] = dtemp; - dtemp = dx[i__ + 1]; - dx[i__ + 1] = dy[i__ + 1]; - dy[i__ + 1] = dtemp; - dtemp = dx[i__ + 2]; - dx[i__ + 2] = dy[i__ + 2]; - dy[i__ + 2] = dtemp; -/* L50: */ - } - return 0; -} /* dswap_ */ diff --git a/3rdparty/lapack/dsyevr.c b/3rdparty/lapack/dsyevr.c deleted file mode 100644 index 898eee7..0000000 --- a/3rdparty/lapack/dsyevr.c +++ /dev/null @@ -1,652 +0,0 @@ -/* dsyevr.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__10 = 10; -static integer c__1 = 1; -static integer c__2 = 2; -static integer c__3 = 3; -static integer c__4 = 4; -static integer c_n1 = -1; - -/* Subroutine */ int dsyevr_(char *jobz, char *range, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer * - il, integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2; - doublereal d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, nb, jj; - doublereal eps, vll, vuu, tmp1; - integer indd, inde; - doublereal anrm; - integer imax; - doublereal rmin, rmax; - integer inddd, indee; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - doublereal sigma; - extern logical lsame_(char *, char *); - integer iinfo; - char order[1]; - integer indwk; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dswap_(integer *, doublereal *, integer - *, doublereal *, integer *); - integer lwmin; - logical lower, wantz; - extern doublereal dlamch_(char *); - logical alleig, indeig; - integer iscale, ieeeok, indibl, indifl; - logical valeig; - doublereal safmin; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *); - doublereal abstll, bignum; - integer indtau, indisp; - extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *, doublereal *, - integer *, doublereal *, integer *, integer *, integer *), - dsterf_(integer *, doublereal *, doublereal *, integer *); - integer indiwo, indwkn; - extern doublereal dlansy_(char *, char *, integer *, doublereal *, - integer *, doublereal *); - extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal - *, doublereal *, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, integer *, doublereal *, integer *, - integer *, doublereal *, integer *, integer *), - dstemr_(char *, char *, integer *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, integer *, - logical *, doublereal *, integer *, integer *, integer *, integer - *); - integer liwmin; - logical tryrac; - extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *); - integer llwrkn, llwork, nsplit; - doublereal smlnum; - extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - integer *, integer *); - integer lwkopt; - logical lquery; - - -/* -- LAPACK driver routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYEVR computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ -/* selected by specifying either a range of values or a range of */ -/* indices for the desired eigenvalues. */ - -/* DSYEVR first reduces the matrix A to tridiagonal form T with a call */ -/* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute */ -/* the eigenspectrum using Relatively Robust Representations. DSTEMR */ -/* computes eigenvalues by the dqds algorithm, while orthogonal */ -/* eigenvectors are computed from various "good" L D L^T representations */ -/* (also known as Relatively Robust Representations). Gram-Schmidt */ -/* orthogonalization is avoided as far as possible. More specifically, */ -/* the various steps of the algorithm are as follows. */ - -/* For each unreduced block (submatrix) of T, */ -/* (a) Compute T - sigma I = L D L^T, so that L and D */ -/* define all the wanted eigenvalues to high relative accuracy. */ -/* This means that small relative changes in the entries of D and L */ -/* cause only small relative changes in the eigenvalues and */ -/* eigenvectors. The standard (unfactored) representation of the */ -/* tridiagonal matrix T does not have this property in general. */ -/* (b) Compute the eigenvalues to suitable accuracy. */ -/* If the eigenvectors are desired, the algorithm attains full */ -/* accuracy of the computed eigenvalues only right before */ -/* the corresponding vectors have to be computed, see steps c) and d). */ -/* (c) For each cluster of close eigenvalues, select a new */ -/* shift close to the cluster, find a new factorization, and refine */ -/* the shifted eigenvalues to suitable accuracy. */ -/* (d) For each eigenvalue with a large enough relative separation compute */ -/* the corresponding eigenvector by forming a rank revealing twisted */ -/* factorization. Go back to (c) for any clusters that remain. */ - -/* The desired accuracy of the output can be specified by the input */ -/* parameter ABSTOL. */ - -/* For more details, see DSTEMR's documentation and: */ -/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* 2004. Also LAPACK Working Note 154. */ -/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* tridiagonal eigenvalue/eigenvector problem", */ -/* Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* UC Berkeley, May 1997. */ - - -/* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested */ -/* on machines which conform to the ieee-754 floating point standard. */ -/* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and */ -/* when partial spectrum requests are made. */ - -/* Normal execution of DSTEMR may create NaNs and infinities and */ -/* hence may abort due to a floating point exception in environments */ -/* which do not handle NaNs and infinities in the ieee standard default */ -/* manner. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ -/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ -/* ********* DSTEIN are called */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, 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. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ -/* On exit, the lower triangle (if UPLO='L') or the upper */ -/* triangle (if UPLO='U') of A, including the diagonal, is */ -/* destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. 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'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing A to tridiagonal form. */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices */ -/* with Guaranteed High Relative Accuracy," by Demmel and */ -/* Kahan, LAPACK Working Note #3. */ - -/* If high relative accuracy is important, set ABSTOL to */ -/* DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ -/* eigenvalues are computed to high relative accuracy when */ -/* possible in future releases. The current code does not */ -/* make any guarantees about high relative accuracy, but */ -/* future releases will. See J. Barlow and J. Demmel, */ -/* "Computing Accurate Eigensystems of Scaled Diagonally */ -/* Dominant Matrices", LAPACK Working Note #7, for a discussion */ -/* of which matrices define their eigenvalues to high relative */ -/* accuracy. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ -/* Supplying N columns is always safe. */ - -/* 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 ). */ -/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 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 >= max(1,26*N). */ -/* For optimal efficiency, LWORK >= (NB+6)*N, */ -/* where NB is the max of the blocksize for DSYTRD and DORMTR */ -/* 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. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: Internal error */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Inderjit Dhillon, IBM Almaden, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Ken Stanley, Computer Science Division, University of */ -/* California at Berkeley, USA */ -/* Jason Riedy, 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 */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - ieeeok = ilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4); - - lower = lsame_(uplo, "L"); - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - lquery = *lwork == -1 || *liwork == -1; - -/* Computing MAX */ - i__1 = 1, i__2 = *n * 26; - lwmin = max(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = max(i__1,i__2); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < max(1,*n)) { - *info = -6; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -8; - } - } else if (indeig) { - if (*il < 1 || *il > max(1,*n)) { - *info = -9; - } else if (*iu < min(*n,*il) || *iu > *n) { - *info = -10; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -15; - } else if (*lwork < lwmin && ! lquery) { - *info = -18; - } else if (*liwork < liwmin && ! lquery) { - *info = -20; - } - } - - if (*info == 0) { - nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, & - c_n1); - nb = max(i__1,i__2); -/* Computing MAX */ - i__1 = (nb + 1) * *n; - lwkopt = max(i__1,lwmin); - work[1] = (doublereal) lwkopt; - iwork[1] = liwmin; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYEVR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - work[1] = 1.; - return 0; - } - - if (*n == 1) { - work[1] = 7.; - if (alleig || indeig) { - *m = 1; - w[1] = a[a_dim1 + 1]; - } else { - if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { - *m = 1; - w[1] = a[a_dim1 + 1]; - } - } - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = min(d__1,d__2); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - abstll = *abstol; - vll = *vl; - vuu = *vu; - anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - if (lower) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j + 1; - dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); -/* L10: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); -/* L20: */ - } - } - if (*abstol > 0.) { - abstll = *abstol * sigma; - } - if (valeig) { - vll = *vl * sigma; - vuu = *vu * sigma; - } - } -/* Initialize indices into workspaces. Note: The IWORK indices are */ -/* used only if DSTERF or DSTEMR fail. */ -/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */ -/* elementary reflectors used in DSYTRD. */ - indtau = 1; -/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */ - indd = indtau + *n; -/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */ -/* tridiagonal matrix from DSYTRD. */ - inde = indd + *n; -/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */ -/* -written by DSTEMR (the DSTERF path copies the diagonal to W). */ - inddd = inde + *n; -/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */ -/* -written while computing the eigenvalues in DSTERF and DSTEMR. */ - indee = inddd + *n; -/* INDWK is the starting offset of the left-over workspace, and */ -/* LLWORK is the remaining workspace size. */ - indwk = indee + *n; - llwork = *lwork - indwk + 1; -/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */ -/* stores the block indices of each of the M<=N eigenvalues. */ - indibl = 1; -/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */ -/* stores the starting and finishing indices of each block. */ - indisp = indibl + *n; -/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ -/* that corresponding to eigenvectors that fail to converge in */ -/* DSTEIN. This information is discarded; if any fail, the driver */ -/* returns INFO > 0. */ - indifl = indisp + *n; -/* INDIWO is the offset of the remaining integer workspace. */ - indiwo = indisp + *n; - -/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ - - dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ - indtau], &work[indwk], &llwork, &iinfo); - -/* If all eigenvalues are desired */ -/* then call DSTERF or DSTEMR and DORMTR. */ - - if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) { - if (! wantz) { - dcopy_(n, &work[indd], &c__1, &w[1], &c__1); - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dsterf_(n, &w[1], &work[indee], info); - } else { - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dcopy_(n, &work[indd], &c__1, &work[inddd], &c__1); - - if (*abstol <= *n * 2. * eps) { - tryrac = TRUE_; - } else { - tryrac = FALSE_; - } - dstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu, - m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, & - work[indwk], lwork, &iwork[1], liwork, info); - - - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by DSTEIN. */ - - if (wantz && *info == 0) { - indwkn = inde; - llwrkn = *lwork - indwkn + 1; - dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau] -, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); - } - } - - - if (*info == 0) { -/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are */ -/* undefined. */ - *m = *n; - goto L30; - } - *info = 0; - } - -/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */ -/* Also call DSTEBZ and DSTEIN if DSTEMR fails. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ - inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwk], &iwork[indiwo], info); - - if (wantz) { - dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ - indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], & - iwork[indifl], info); - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by DSTEIN. */ - - indwkn = inde; - llwrkn = *lwork - indwkn + 1; - dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ - z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - -/* Jump here if DSTEMR/DSTEIN succeeded. */ -L30: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. */ -/* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do */ -/* not return this detailed information to the user. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L40: */ - } - - if (i__ != 0) { - w[i__] = w[j]; - w[j] = tmp1; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - } -/* L50: */ - } - } - -/* Set WORK(1) to optimal workspace size. */ - - work[1] = (doublereal) lwkopt; - iwork[1] = liwmin; - - return 0; - -/* End of DSYEVR */ - -} /* dsyevr_ */ diff --git a/3rdparty/lapack/dsymv.c b/3rdparty/lapack/dsymv.c deleted file mode 100644 index aa190ec..0000000 --- a/3rdparty/lapack/dsymv.c +++ /dev/null @@ -1,313 +0,0 @@ -/* dsymv.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 dsymv_(char *uplo, integer *n, doublereal *alpha, - doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal - *beta, doublereal *y, integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, iy, jx, jy, kx, ky, info; - doublereal temp1, temp2; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array A is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of A */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of A */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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 with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of A is not referenced. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of A is not referenced. */ -/* 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, n ). */ -/* Unchanged on exit. */ - -/* X - DOUBLE PRECISION array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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. */ - -/* 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 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the n */ -/* element 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. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*lda < max(1,*n)) { - info = 5; - } else if (*incx == 0) { - info = 7; - } else if (*incy == 0) { - info = 10; - } - if (info != 0) { - xerbla_("DSYMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the triangular part */ -/* of A. */ - -/* First form y := beta*y. */ - - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - if (lsame_(uplo, "U")) { - -/* Form y when A is stored in upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[i__]; -/* L50: */ - } - y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; - jx += *incx; - jy += *incy; -/* L80: */ - } - } - } else { - -/* Form y when A is stored in lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * a[j + j * a_dim1]; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[j] += *alpha * temp2; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * a[j + j * a_dim1]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of DSYMV . */ - -} /* dsymv_ */ diff --git a/3rdparty/lapack/dsyr.c b/3rdparty/lapack/dsyr.c deleted file mode 100644 index a4616b1..0000000 --- a/3rdparty/lapack/dsyr.c +++ /dev/null @@ -1,238 +0,0 @@ -/* dsyr.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 dsyr_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, jx, kx, info; - doublereal temp; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYR performs the symmetric rank 1 operation */ - -/* A := alpha*x*x' + A, */ - -/* where alpha is a real scalar, x is an n element vector and A is an */ -/* n by n symmetric matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array A is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of A */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of A */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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. */ - -/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of A is not referenced. On exit, the */ -/* upper triangular part of the array A is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of A is not referenced. On exit, the */ -/* lower triangular part of the array A is overwritten by the */ -/* lower triangular part of 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, n ). */ -/* 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. */ - - /* Parameter adjustments */ - --x; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*lda < max(1,*n)) { - info = 7; - } - if (info != 0) { - xerbla_("DSYR ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0.) { - return 0; - } - -/* Set the start point in X if the increment is not unity. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the triangular part */ -/* of A. */ - - if (lsame_(uplo, "U")) { - -/* Form A when A is stored in upper triangle. */ - - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[i__] * temp; -/* L10: */ - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = kx; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[ix] * temp; - ix += *incx; -/* L30: */ - } - } - jx += *incx; -/* L40: */ - } - } - } else { - -/* Form A when A is stored in lower triangle. */ - - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[i__] * temp; -/* L50: */ - } - } -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = jx; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[ix] * temp; - ix += *incx; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } - - return 0; - -/* End of DSYR . */ - -} /* dsyr_ */ diff --git a/3rdparty/lapack/dsyr2.c b/3rdparty/lapack/dsyr2.c deleted file mode 100644 index 472d6d7..0000000 --- a/3rdparty/lapack/dsyr2.c +++ /dev/null @@ -1,275 +0,0 @@ -/* dsyr2.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 dsyr2_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, iy, jx, jy, kx, ky, info; - doublereal temp1, temp2; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYR2 performs the symmetric rank 2 operation */ - -/* A := alpha*x*y' + alpha*y*x' + A, */ - -/* where alpha is a scalar, x and y are n element vectors and A is an n */ -/* by n symmetric matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array A is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of A */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of A */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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 with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of A is not referenced. On exit, the */ -/* upper triangular part of the array A is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of A is not referenced. On exit, the */ -/* lower triangular part of the array A is overwritten by the */ -/* lower triangular part of 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, n ). */ -/* 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. */ - - /* Parameter adjustments */ - --x; - --y; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*incy == 0) { - info = 7; - } else if (*lda < max(1,*n)) { - info = 9; - } - if (info != 0) { - xerbla_("DSYR2 ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0.) { - return 0; - } - -/* Set up the start points in X and Y if the increments are not both */ -/* unity. */ - - if (*incx != 1 || *incy != 1) { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - jx = kx; - jy = ky; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the triangular part */ -/* of A. */ - - if (lsame_(uplo, "U")) { - -/* Form A when A is stored in the upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * - temp1 + y[i__] * temp2; -/* L10: */ - } - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = kx; - iy = ky; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * - temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L30: */ - } - } - jx += *incx; - jy += *incy; -/* L40: */ - } - } - } else { - -/* Form A when A is stored in the lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * - temp1 + y[i__] * temp2; -/* L50: */ - } - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * - temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L70: */ - } - } - jx += *incx; - jy += *incy; -/* L80: */ - } - } - } - - return 0; - -/* End of DSYR2 . */ - -} /* dsyr2_ */ diff --git a/3rdparty/lapack/dsyr2k.c b/3rdparty/lapack/dsyr2k.c deleted file mode 100644 index 56f4729..0000000 --- a/3rdparty/lapack/dsyr2k.c +++ /dev/null @@ -1,407 +0,0 @@ -/* dsyr2k.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 dsyr2k_(char *uplo, char *trans, 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; - doublereal temp1, temp2; - extern logical lsame_(char *, char *); - integer nrowa; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYR2K performs one of the symmetric rank 2k operations */ - -/* C := alpha*A*B' + alpha*B*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*B + alpha*B'*A + beta*C, */ - -/* where alpha and beta are scalars, C is an n by n symmetric matrix */ -/* and A and B are n by k matrices in the first case and k by n */ -/* matrices in the second case. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */ -/* beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */ -/* beta*C. */ - -/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */ -/* beta*C. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrices A and B, and on entry with */ -/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ -/* of rows of the matrices A and 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 TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array A must contain the matrix A, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */ -/* k when TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array B must contain the matrix B, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDB must be at least max( 1, n ), otherwise LDB must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - DOUBLE PRECISION. */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array C must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of C is not referenced. On exit, the */ -/* upper triangular part of the array C is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array C must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of C is not referenced. On exit, the */ -/* lower triangular part of the array C is overwritten by the */ -/* lower triangular part of the updated matrix. */ - -/* 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, n ). */ -/* 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 .. */ -/* .. */ - -/* Test the input parameters. */ - - /* 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 */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < max(1,nrowa)) { - info = 7; - } else if (*ldb < max(1,nrowa)) { - info = 9; - } else if (*ldc < max(1,*n)) { - info = 12; - } - if (info != 0) { - xerbla_("DSYR2K", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - 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 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } - -/* Start the operations. */ - - if (lsame_(trans, "N")) { - -/* Form C := alpha*A*B' + alpha*B*A' + C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L90: */ - } - } else if (*beta != 1.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { - temp1 = *alpha * b[j + l * b_dim1]; - temp2 = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ - i__ + l * a_dim1] * temp1 + b[i__ + l * - b_dim1] * temp2; -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { - temp1 = *alpha * b[j + l * b_dim1]; - temp2 = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ - i__ + l * a_dim1] * temp1 + b[i__ + l * - b_dim1] * temp2; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { - -/* Form C := alpha*A'*B + alpha*B'*A + C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1 = 0.; - temp2 = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; - temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; -/* L190: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * - temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + *alpha * temp1 + *alpha * temp2; - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp1 = 0.; - temp2 = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; - temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; -/* L220: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * - temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + *alpha * temp1 + *alpha * temp2; - } -/* L230: */ - } -/* L240: */ - } - } - } - - return 0; - -/* End of DSYR2K. */ - -} /* dsyr2k_ */ diff --git a/3rdparty/lapack/dsyrk.c b/3rdparty/lapack/dsyrk.c deleted file mode 100644 index b8cd9b4..0000000 --- a/3rdparty/lapack/dsyrk.c +++ /dev/null @@ -1,372 +0,0 @@ -/* dsyrk.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 dsyrk_(char *uplo, char *trans, integer *n, integer *k, - doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, - doublereal *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, info; - doublereal temp; - extern logical lsame_(char *, char *); - integer nrowa; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYRK performs one of the symmetric rank k operations */ - -/* C := alpha*A*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*A + beta*C, */ - -/* where alpha and beta are scalars, C is an n by n symmetric matrix */ -/* and A is an n by k matrix in the first case and a k by n matrix */ -/* in the second case. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ - -/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrix A, and on entry with */ -/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ -/* of rows of the matrix A. 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 TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array A must contain the matrix A, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - DOUBLE PRECISION. */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array C must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of C is not referenced. On exit, the */ -/* upper triangular part of the array C is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array C must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of C is not referenced. On exit, the */ -/* lower triangular part of the array C is overwritten by the */ -/* lower triangular part of the updated matrix. */ - -/* 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, n ). */ -/* 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 .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < max(1,nrowa)) { - info = 7; - } else if (*ldc < max(1,*n)) { - info = 10; - } - if (info != 0) { - xerbla_("DSYRK ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - 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 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } - -/* Start the operations. */ - - if (lsame_(trans, "N")) { - -/* Form C := alpha*A*A' + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L90: */ - } - } else if (*beta != 1.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { - -/* Form C := alpha*A'*A + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - 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] * a[l + j * a_dim1]; -/* L190: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; -/* L220: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L230: */ - } -/* L240: */ - } - } - } - - return 0; - -/* End of DSYRK . */ - -} /* dsyrk_ */ diff --git a/3rdparty/lapack/dsytd2.c b/3rdparty/lapack/dsytd2.c deleted file mode 100644 index 31e70ad..0000000 --- a/3rdparty/lapack/dsytd2.c +++ /dev/null @@ -1,306 +0,0 @@ -/* dsytd2.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.; -static doublereal c_b14 = -1.; - -/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - doublereal taui; - extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - doublereal alpha; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - logical upper; - extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *), 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 */ -/* ======= */ - -/* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */ -/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ -/* of A are overwritten by the corresponding elements of the */ -/* tridiagonal matrix T, and the elements above the first */ -/* superdiagonal, with the array TAU, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors; if UPLO */ -/* = 'L', the diagonal and first subdiagonal of A are over- */ -/* written by the corresponding elements of the tridiagonal */ -/* matrix T, and the elements below the first subdiagonal, 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,N). */ - -/* D (output) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T: */ -/* D(i) = A(i,i). */ - -/* E (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix T: */ -/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n-1) . . . H(2) H(1). */ - -/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ -/* A(1:i-1,i+1), and tau in TAU(i). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(n-1). */ - -/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ -/* and tau in TAU(i). */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( d e v2 v3 v4 ) ( d ) */ -/* ( d e v3 v4 ) ( e d ) */ -/* ( d e v4 ) ( v1 e d ) */ -/* ( d e ) ( v1 v2 e d ) */ -/* ( d ) ( v1 v2 v3 e d ) */ - -/* where d and e denote diagonal and off-diagonal elements of T, and vi */ -/* denotes an element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. 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; - --d__; - --e; - --tau; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTD2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - - if (upper) { - -/* Reduce the upper triangle of A */ - - for (i__ = *n - 1; i__ >= 1; --i__) { - -/* Generate elementary reflector H(i) = I - tau * v * v' */ -/* to annihilate A(1:i-1,i+1) */ - - dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 - + 1], &c__1, &taui); - e[i__] = a[i__ + (i__ + 1) * a_dim1]; - - if (taui != 0.) { - -/* Apply H(i) from both sides to A(1:i,1:i) */ - - a[i__ + (i__ + 1) * a_dim1] = 1.; - -/* Compute x := tau * A * v storing x in TAU(1:i) */ - - dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * - a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1); - -/* Compute w := x - 1/2 * tau * (x'*v) * v */ - - alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) - * a_dim1 + 1], &c__1); - daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ - 1], &c__1); - -/* Apply the transformation as a rank-2 update: */ -/* A := A - v * w' - w * v' */ - - dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, - &tau[1], &c__1, &a[a_offset], lda); - - a[i__ + (i__ + 1) * a_dim1] = e[i__]; - } - d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1]; - tau[i__] = taui; -/* L10: */ - } - d__[1] = a[a_dim1 + 1]; - } else { - -/* Reduce the lower triangle of A */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) = I - tau * v * v' */ -/* to annihilate A(i+2:n,i) */ - - i__2 = *n - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ * - a_dim1], &c__1, &taui); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - - if (taui != 0.) { - -/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ - - a[i__ + 1 + i__ * a_dim1] = 1.; - -/* Compute x := tau * A * v storing y in TAU(i:n-1) */ - - i__2 = *n - i__; - dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ - i__], &c__1); - -/* Compute w := x - 1/2 * tau * (x'*v) * v */ - - i__2 = *n - i__; - alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + - 1 + i__ * a_dim1], &c__1); - i__2 = *n - i__; - daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ - i__], &c__1); - -/* Apply the transformation as a rank-2 update: */ -/* A := A - v * w' - w * v' */ - - i__2 = *n - i__; - dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, - &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda); - - a[i__ + 1 + i__ * a_dim1] = e[i__]; - } - d__[i__] = a[i__ + i__ * a_dim1]; - tau[i__] = taui; -/* L20: */ - } - d__[*n] = a[*n + *n * a_dim1]; - } - - return 0; - -/* End of DSYTD2 */ - -} /* dsytd2_ */ diff --git a/3rdparty/lapack/dsytf2.c b/3rdparty/lapack/dsytf2.c deleted file mode 100644 index fcbf7b3..0000000 --- a/3rdparty/lapack/dsytf2.c +++ /dev/null @@ -1,608 +0,0 @@ -/* dsytf2.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 dsytf2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, k; - doublereal t, r1, d11, d12, d21, d22; - integer kk, kp; - doublereal wk, wkm1, wkp1; - integer imax, jmax; - extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *); - doublereal alpha; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *); - integer kstep; - logical upper; - doublereal absakk; - extern integer idamax_(integer *, doublereal *, integer *); - extern logical disnan_(doublereal *); - extern /* Subroutine */ int xerbla_(char *, integer *); - doublereal colmax, rowmax; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYTF2 computes the factorization of a real symmetric matrix A using */ -/* the Bunch-Kaufman diagonal pivoting method: */ - -/* A = U*D*U' or A = L*D*L' */ - -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, U' is the transpose of U, and D is symmetric and */ -/* block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ - -/* On exit, the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L (see below for further details). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D. */ -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular, and division by zero will occur if it */ -/* is used to solve a system of equations. */ - -/* Further Details */ -/* =============== */ - -/* 09-29-06 - patch from */ -/* Bobby Cheng, MathWorks */ - -/* Replace l.204 and l.372 */ -/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */ -/* by */ -/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */ - -/* 01-01-96 - Based on modifications by */ -/* J. Lewis, Boeing Computer Services Company */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ -/* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */ -/* Company */ - -/* If UPLO = 'U', then A = U*D*U', where */ -/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */ -/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ -/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I v 0 ) k-s */ -/* U(k) = ( 0 I 0 ) s */ -/* ( 0 0 I ) n-k */ -/* k-s s n-k */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ -/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ -/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */ - -/* If UPLO = 'L', then A = L*D*L', where */ -/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ -/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ -/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I 0 0 ) k-1 */ -/* L(k) = ( 0 I 0 ) s */ -/* ( 0 v I ) n-k-s+1 */ -/* k-1 s n-k-s+1 */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ -/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ -/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ - -/* ===================================================================== */ - -/* .. 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; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTF2", &i__1); - return 0; - } - -/* Initialize ALPHA for use in choosing pivot block size. */ - - alpha = (sqrt(17.) + 1.) / 8.; - - if (upper) { - -/* Factorize A as U*D*U' using the upper triangle of A */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2 */ - - k = *n; -L10: - -/* If K < 1, exit from loop */ - - if (k < 1) { - goto L70; - } - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k > 1) { - i__1 = k - 1; - imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1); - colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); - } else { - colmax = 0.; - } - - if (max(absakk,colmax) == 0. || disnan_(&absakk)) { - -/* Column K is zero or contains a NaN: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - i__1 = k - imax; - jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * a_dim1], - lda); - rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); - if (imax > 1) { - i__1 = imax - 1; - jmax = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], - abs(d__1)); - rowmax = max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >= - alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - } else { - -/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k - kstep + 1; - if (kp != kk) { - -/* Interchange rows and columns KK and KP in the leading */ -/* submatrix A(1:k,1:k) */ - - i__1 = kp - 1; - dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], - &c__1); - i__1 = kk - kp - 1; - dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + - 1) * a_dim1], lda); - t = a[kk + kk * a_dim1]; - a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; - a[kp + kp * a_dim1] = t; - if (kstep == 2) { - t = a[k - 1 + k * a_dim1]; - a[k - 1 + k * a_dim1] = a[kp + k * a_dim1]; - a[kp + k * a_dim1] = t; - } - } - -/* Update the leading submatrix */ - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column k now holds */ - -/* W(k) = U(k)*D(k) */ - -/* where U(k) is the k-th column of U */ - -/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ - -/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */ - - r1 = 1. / a[k + k * a_dim1]; - i__1 = k - 1; - d__1 = -r1; - dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[ - a_offset], lda); - -/* Store U(k) in column k */ - - i__1 = k - 1; - dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); - } else { - -/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ - -/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ - -/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ -/* of U */ - -/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ - -/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */ -/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */ - - if (k > 2) { - - d12 = a[k - 1 + k * a_dim1]; - d22 = a[k - 1 + (k - 1) * a_dim1] / d12; - d11 = a[k + k * a_dim1] / d12; - t = 1. / (d11 * d22 - 1.); - d12 = t / d12; - - for (j = k - 2; j >= 1; --j) { - wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k - * a_dim1]); - wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * - a_dim1]); - for (i__ = j; i__ >= 1; --i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] * wk - a[i__ + (k - 1) * - a_dim1] * wkm1; -/* L20: */ - } - a[j + k * a_dim1] = wk; - a[j + (k - 1) * a_dim1] = wkm1; -/* L30: */ - } - - } - - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k - 1] = -kp; - } - -/* Decrease K and return to the start of the main loop */ - - k -= kstep; - goto L10; - - } else { - -/* Factorize A as L*D*L' using the lower triangle of A */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2 */ - - k = 1; -L40: - -/* If K > N, exit from loop */ - - if (k > *n) { - goto L70; - } - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k < *n) { - i__1 = *n - k; - imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1); - colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); - } else { - colmax = 0.; - } - - if (max(absakk,colmax) == 0. || disnan_(&absakk)) { - -/* Column K is zero or contains a NaN: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - i__1 = imax - k; - jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda); - rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); - if (imax < *n) { - i__1 = *n - imax; - jmax = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1], - &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], - abs(d__1)); - rowmax = max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >= - alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - } else { - -/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k + kstep - 1; - if (kp != kk) { - -/* Interchange rows and columns KK and KP in the trailing */ -/* submatrix A(k:n,k:n) */ - - if (kp < *n) { - i__1 = *n - kp; - dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 - + kp * a_dim1], &c__1); - } - i__1 = kp - kk - 1; - dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + - 1) * a_dim1], lda); - t = a[kk + kk * a_dim1]; - a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; - a[kp + kp * a_dim1] = t; - if (kstep == 2) { - t = a[k + 1 + k * a_dim1]; - a[k + 1 + k * a_dim1] = a[kp + k * a_dim1]; - a[kp + k * a_dim1] = t; - } - } - -/* Update the trailing submatrix */ - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column k now holds */ - -/* W(k) = L(k)*D(k) */ - -/* where L(k) is the k-th column of L */ - - if (k < *n) { - -/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ - -/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */ - - d11 = 1. / a[k + k * a_dim1]; - i__1 = *n - k; - d__1 = -d11; - dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, & - a[k + 1 + (k + 1) * a_dim1], lda); - -/* Store L(k) in column K */ - - i__1 = *n - k; - dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1); - } - } else { - -/* 2-by-2 pivot block D(k) */ - - if (k < *n - 1) { - -/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ - -/* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))' */ - -/* where L(k) and L(k+1) are the k-th and (k+1)-th */ -/* columns of L */ - - d21 = a[k + 1 + k * a_dim1]; - d11 = a[k + 1 + (k + 1) * a_dim1] / d21; - d22 = a[k + k * a_dim1] / d21; - t = 1. / (d11 * d22 - 1.); - d21 = t / d21; - - i__1 = *n; - for (j = k + 2; j <= i__1; ++j) { - - wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * - a_dim1]); - wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k - * a_dim1]); - - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] * wk - a[i__ + (k + 1) * - a_dim1] * wkp1; -/* L50: */ - } - - a[j + k * a_dim1] = wk; - a[j + (k + 1) * a_dim1] = wkp1; - -/* L60: */ - } - } - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k + 1] = -kp; - } - -/* Increase K and return to the start of the main loop */ - - k += kstep; - goto L40; - - } - -L70: - - return 0; - -/* End of DSYTF2 */ - -} /* dsytf2_ */ diff --git a/3rdparty/lapack/dsytrd.c b/3rdparty/lapack/dsytrd.c deleted file mode 100644 index 79c1f7e..0000000 --- a/3rdparty/lapack/dsytrd.c +++ /dev/null @@ -1,360 +0,0 @@ -/* dsytrd.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_b22 = -1.; -static doublereal c_b23 = 1.; - -/* Subroutine */ int dsytrd_(char *uplo, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tau, 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, nb, kk, nx, iws; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - logical upper; - extern /* Subroutine */ int dsytd2_(char *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, integer *), dsyr2k_(char *, char *, integer *, integer *, doublereal - *, doublereal *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *), dlatrd_(char *, - integer *, integer *, doublereal *, integer *, doublereal *, - 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 */ -/* ======= */ - -/* DSYTRD reduces a real symmetric matrix A to real symmetric */ -/* tridiagonal form T by an orthogonal similarity transformation: */ -/* Q**T * A * Q = T. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ -/* of A are overwritten by the corresponding elements of the */ -/* tridiagonal matrix T, and the elements above the first */ -/* superdiagonal, with the array TAU, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors; if UPLO */ -/* = 'L', the diagonal and first subdiagonal of A are over- */ -/* written by the corresponding elements of the tridiagonal */ -/* matrix T, and the elements below the first subdiagonal, 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,N). */ - -/* D (output) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T: */ -/* D(i) = A(i,i). */ - -/* E (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix T: */ -/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* 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 >= 1. */ -/* 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 */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n-1) . . . H(2) H(1). */ - -/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ -/* A(1:i-1,i+1), and tau in TAU(i). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(n-1). */ - -/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ -/* and tau in TAU(i). */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( d e v2 v3 v4 ) ( d ) */ -/* ( d e v3 v4 ) ( e d ) */ -/* ( d e v4 ) ( v1 e d ) */ -/* ( d e ) ( v1 v2 e d ) */ -/* ( d ) ( v1 v2 v3 e d ) */ - -/* where d and e denote diagonal and off-diagonal elements of T, and vi */ -/* denotes an element of the vector defining H(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; - --tau; - --work; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } else if (*lwork < 1 && ! lquery) { - *info = -9; - } - - if (*info == 0) { - -/* Determine the block size. */ - - nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTRD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - work[1] = 1.; - return 0; - } - - nx = *n; - iws = 1; - if (nb > 1 && nb < *n) { - -/* Determine when to cross over from blocked to unblocked code */ -/* (last block is always handled by unblocked code). */ - -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, "DSYTRD", uplo, n, &c_n1, &c_n1, & - c_n1); - nx = max(i__1,i__2); - if (nx < *n) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: determine the */ -/* minimum value of NB, and reduce NB or force use of */ -/* unblocked code by setting NX = N. */ - -/* Computing MAX */ - i__1 = *lwork / ldwork; - nb = max(i__1,1); - nbmin = ilaenv_(&c__2, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); - if (nb < nbmin) { - nx = *n; - } - } - } else { - nx = *n; - } - } else { - nb = 1; - } - - if (upper) { - -/* Reduce the upper triangle of A. */ -/* Columns 1:kk are handled by the unblocked method. */ - - kk = *n - (*n - nx + nb - 1) / nb * nb; - i__1 = kk + 1; - i__2 = -nb; - for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { - -/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ -/* matrix W which is needed to update the unreduced part of */ -/* the matrix */ - - i__3 = i__ + nb - 1; - dlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & - work[1], &ldwork); - -/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ -/* update of the form: A := A - V*W' - W*V' */ - - i__3 = i__ - 1; - dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 - + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda); - -/* Copy superdiagonal elements back into A, and diagonal */ -/* elements into D */ - - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j - 1 + j * a_dim1] = e[j - 1]; - d__[j] = a[j + j * a_dim1]; -/* L10: */ - } -/* L20: */ - } - -/* Use unblocked code to reduce the last or only block */ - - dsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo); - } else { - -/* Reduce the lower triangle of A */ - - i__2 = *n - nx; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { - -/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ -/* matrix W which is needed to update the unreduced part of */ -/* the matrix */ - - i__3 = *n - i__ + 1; - dlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & - tau[i__], &work[1], &ldwork); - -/* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */ -/* an update of the form: A := A - V*W' - W*V' */ - - i__3 = *n - i__ - nb + 1; - dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + - i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ - i__ + nb + (i__ + nb) * a_dim1], lda); - -/* Copy subdiagonal elements back into A, and diagonal */ -/* elements into D */ - - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j + 1 + j * a_dim1] = e[j]; - d__[j] = a[j + j * a_dim1]; -/* L30: */ - } -/* L40: */ - } - -/* Use unblocked code to reduce the last or only block */ - - i__1 = *n - i__ + 1; - dsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], - &tau[i__], &iinfo); - } - - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DSYTRD */ - -} /* dsytrd_ */ diff --git a/3rdparty/lapack/dsytrf.c b/3rdparty/lapack/dsytrf.c deleted file mode 100644 index 9ee6574..0000000 --- a/3rdparty/lapack/dsytrf.c +++ /dev/null @@ -1,341 +0,0 @@ -/* dsytrf.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; - -/* Subroutine */ int dsytrf_(char *uplo, 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; - - /* Local variables */ - integer j, k, kb, nb, iws; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - logical upper; - extern /* Subroutine */ int dsytf2_(char *, integer *, doublereal *, - integer *, integer *, integer *), xerbla_(char *, integer - *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int dlasyf_(char *, integer *, integer *, integer - *, doublereal *, integer *, integer *, doublereal *, 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 */ -/* ======= */ - -/* DSYTRF computes the factorization of a real symmetric matrix A using */ -/* the Bunch-Kaufman diagonal pivoting method. The form of the */ -/* factorization is */ - -/* A = U*D*U**T or A = L*D*L**T */ - -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, and D is symmetric and block diagonal with */ -/* 1-by-1 and 2-by-2 diagonal blocks. */ - -/* This is the blocked version of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ - -/* On exit, the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L (see below for further details). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D. */ -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* 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 WORK. LWORK >=1. For best performance */ -/* LWORK >= N*NB, where NB is the block size 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, D(i,i) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular, and division by zero will occur if it */ -/* is used to solve a system of equations. */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', then A = U*D*U', where */ -/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */ -/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ -/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I v 0 ) k-s */ -/* U(k) = ( 0 I 0 ) s */ -/* ( 0 0 I ) n-k */ -/* k-s s n-k */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ -/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ -/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */ - -/* If UPLO = 'L', then A = L*D*L', where */ -/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ -/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ -/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I 0 0 ) k-1 */ -/* L(k) = ( 0 I 0 ) s */ -/* ( 0 v I ) n-k-s+1 */ -/* k-1 s n-k-s+1 */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ -/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ -/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ - -/* ===================================================================== */ - -/* .. 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; - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } else if (*lwork < 1 && ! lquery) { - *info = -7; - } - - if (*info == 0) { - -/* Determine the block size */ - - nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTRF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - - nbmin = 2; - ldwork = *n; - if (nb > 1 && nb < *n) { - iws = ldwork * nb; - if (*lwork < iws) { -/* Computing MAX */ - i__1 = *lwork / ldwork; - nb = max(i__1,1); -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DSYTRF", uplo, n, &c_n1, &c_n1, & - c_n1); - nbmin = max(i__1,i__2); - } - } else { - iws = 1; - } - if (nb < nbmin) { - nb = *n; - } - - if (upper) { - -/* Factorize A as U*D*U' using the upper triangle of A */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* KB, where KB is the number of columns factorized by DLASYF; */ -/* KB is either NB or NB-1, or K for the last block */ - - k = *n; -L10: - -/* If K < 1, exit from loop */ - - if (k < 1) { - goto L40; - } - - if (k > nb) { - -/* Factorize columns k-kb+1:k of A and use blocked code to */ -/* update columns 1:k-kb */ - - dlasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1], - &ldwork, &iinfo); - } else { - -/* Use unblocked code to factorize columns 1:k of A */ - - dsytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo); - kb = k; - } - -/* Set INFO on the first occurrence of a zero pivot */ - - if (*info == 0 && iinfo > 0) { - *info = iinfo; - } - -/* Decrease K and return to the start of the main loop */ - - k -= kb; - goto L10; - - } else { - -/* Factorize A as L*D*L' using the lower triangle of A */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* KB, where KB is the number of columns factorized by DLASYF; */ -/* KB is either NB or NB-1, or N-K+1 for the last block */ - - k = 1; -L20: - -/* If K > N, exit from loop */ - - if (k > *n) { - goto L40; - } - - if (k <= *n - nb) { - -/* Factorize columns k:k+kb-1 of A and use blocked code to */ -/* update columns k+kb:n */ - - i__1 = *n - k + 1; - dlasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], - &work[1], &ldwork, &iinfo); - } else { - -/* Use unblocked code to factorize columns k:n of A */ - - i__1 = *n - k + 1; - dsytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo); - kb = *n - k + 1; - } - -/* Set INFO on the first occurrence of a zero pivot */ - - if (*info == 0 && iinfo > 0) { - *info = iinfo + k - 1; - } - -/* Adjust IPIV */ - - i__1 = k + kb - 1; - for (j = k; j <= i__1; ++j) { - if (ipiv[j] > 0) { - ipiv[j] = ipiv[j] + k - 1; - } else { - ipiv[j] = ipiv[j] - k + 1; - } -/* L30: */ - } - -/* Increase K and return to the start of the main loop */ - - k += kb; - goto L20; - - } - -L40: - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DSYTRF */ - -} /* dsytrf_ */ diff --git a/3rdparty/lapack/dsytri.c b/3rdparty/lapack/dsytri.c deleted file mode 100644 index cc88033..0000000 --- a/3rdparty/lapack/dsytri.c +++ /dev/null @@ -1,396 +0,0 @@ -/* dsytri.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_b11 = -1.; -static doublereal c_b13 = 0.; - -/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *ipiv, doublereal *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - doublereal d__1; - - /* Local variables */ - doublereal d__; - integer k; - doublereal t, ak; - integer kp; - doublereal akp1; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - doublereal temp, akkp1; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dswap_(integer *, doublereal *, integer - *, doublereal *, integer *); - integer kstep; - logical upper; - extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, 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 */ -/* ======= */ - -/* DSYTRI computes the inverse of a real symmetric indefinite matrix */ -/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ -/* DSYTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the details of the factorization are stored */ -/* as an upper or lower triangular matrix. */ -/* = 'U': Upper triangular, form is A = U*D*U**T; */ -/* = 'L': Lower triangular, form is A = L*D*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the block diagonal matrix D and the multipliers */ -/* used to obtain the factor U or L as computed by DSYTRF. */ - -/* On exit, if INFO = 0, the (symmetric) inverse of the original */ -/* matrix. If UPLO = 'U', the upper triangular part of the */ -/* inverse is formed and the part of A below the diagonal is not */ -/* referenced; if UPLO = 'L' the lower triangular part of the */ -/* inverse is formed and the part of A above the diagonal is */ -/* not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSYTRF. */ - -/* 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 */ -/* > 0: if INFO = i, D(i,i) = 0; 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; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check that the diagonal matrix D is nonsingular. */ - - if (upper) { - -/* Upper triangular storage: examine D from bottom to top */ - - for (*info = *n; *info >= 1; --(*info)) { - if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L10: */ - } - } else { - -/* Lower triangular storage: examine D from top to bottom. */ - - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L20: */ - } - } - *info = 0; - - if (upper) { - -/* Compute inv(A) from the factorization A = U*D*U'. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; -L30: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L40; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Invert the diagonal block. */ - - a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; - -/* Compute column K of the inverse. */ - - if (k > 1) { - i__1 = k - 1; - dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); - i__1 = k - 1; - dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & - c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); - i__1 = k - 1; - a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * - a_dim1 + 1], &c__1); - } - kstep = 1; - } else { - -/* 2 x 2 diagonal block */ - -/* Invert the diagonal block. */ - - t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1)); - ak = a[k + k * a_dim1] / t; - akp1 = a[k + 1 + (k + 1) * a_dim1] / t; - akkp1 = a[k + (k + 1) * a_dim1] / t; - d__ = t * (ak * akp1 - 1.); - a[k + k * a_dim1] = akp1 / d__; - a[k + 1 + (k + 1) * a_dim1] = ak / d__; - a[k + (k + 1) * a_dim1] = -akkp1 / d__; - -/* Compute columns K and K+1 of the inverse. */ - - if (k > 1) { - i__1 = k - 1; - dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); - i__1 = k - 1; - dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & - c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); - i__1 = k - 1; - a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * - a_dim1 + 1], &c__1); - i__1 = k - 1; - a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], & - c__1, &a[(k + 1) * a_dim1 + 1], &c__1); - i__1 = k - 1; - dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & - c__1); - i__1 = k - 1; - dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & - c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1); - i__1 = k - 1; - a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & - a[(k + 1) * a_dim1 + 1], &c__1); - } - kstep = 2; - } - - kp = (i__1 = ipiv[k], abs(i__1)); - if (kp != k) { - -/* Interchange rows and columns K and KP in the leading */ -/* submatrix A(1:k+1,1:k+1) */ - - i__1 = kp - 1; - dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & - c__1); - i__1 = k - kp - 1; - dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * - a_dim1], lda); - temp = a[k + k * a_dim1]; - a[k + k * a_dim1] = a[kp + kp * a_dim1]; - a[kp + kp * a_dim1] = temp; - if (kstep == 2) { - temp = a[k + (k + 1) * a_dim1]; - a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1]; - a[kp + (k + 1) * a_dim1] = temp; - } - } - - k += kstep; - goto L30; -L40: - - ; - } else { - -/* Compute inv(A) from the factorization A = L*D*L'. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = *n; -L50: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L60; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Invert the diagonal block. */ - - a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; - -/* Compute column K of the inverse. */ - - if (k < *n) { - i__1 = *n - k; - dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); - i__1 = *n - k; - dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, - &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & - c__1); - i__1 = *n - k; - a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + - k * a_dim1], &c__1); - } - kstep = 1; - } else { - -/* 2 x 2 diagonal block */ - -/* Invert the diagonal block. */ - - t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1)); - ak = a[k - 1 + (k - 1) * a_dim1] / t; - akp1 = a[k + k * a_dim1] / t; - akkp1 = a[k + (k - 1) * a_dim1] / t; - d__ = t * (ak * akp1 - 1.); - a[k - 1 + (k - 1) * a_dim1] = akp1 / d__; - a[k + k * a_dim1] = ak / d__; - a[k + (k - 1) * a_dim1] = -akkp1 / d__; - -/* Compute columns K-1 and K of the inverse. */ - - if (k < *n) { - i__1 = *n - k; - dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); - i__1 = *n - k; - dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, - &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & - c__1); - i__1 = *n - k; - a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + - k * a_dim1], &c__1); - i__1 = *n - k; - a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1] -, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1); - i__1 = *n - k; - dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & - c__1); - i__1 = *n - k; - dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, - &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1] -, &c__1); - i__1 = *n - k; - a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & - a[k + 1 + (k - 1) * a_dim1], &c__1); - } - kstep = 2; - } - - kp = (i__1 = ipiv[k], abs(i__1)); - if (kp != k) { - -/* Interchange rows and columns K and KP in the trailing */ -/* submatrix A(k-1:n,k-1:n) */ - - if (kp < *n) { - i__1 = *n - kp; - dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * - a_dim1], &c__1); - } - i__1 = kp - k - 1; - dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * - a_dim1], lda); - temp = a[k + k * a_dim1]; - a[k + k * a_dim1] = a[kp + kp * a_dim1]; - a[kp + kp * a_dim1] = temp; - if (kstep == 2) { - temp = a[k + (k - 1) * a_dim1]; - a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1]; - a[kp + (k - 1) * a_dim1] = temp; - } - } - - k -= kstep; - goto L50; -L60: - ; - } - - return 0; - -/* End of DSYTRI */ - -} /* dsytri_ */ diff --git a/3rdparty/lapack/dsytrs.c b/3rdparty/lapack/dsytrs.c deleted file mode 100644 index 04f2d40..0000000 --- a/3rdparty/lapack/dsytrs.c +++ /dev/null @@ -1,453 +0,0 @@ -/* dsytrs.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 integer c__1 = 1; -static doublereal c_b19 = 1.; - -/* Subroutine */ int dsytrs_(char *uplo, 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; - doublereal d__1; - - /* Local variables */ - integer j, k; - doublereal ak, bk; - integer kp; - doublereal akm1, bkm1; - extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - doublereal akm1k; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - doublereal denom; - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *), dswap_(integer *, - doublereal *, integer *, doublereal *, integer *); - logical upper; - 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 */ -/* ======= */ - -/* DSYTRS solves a system of linear equations A*X = B with a real */ -/* symmetric matrix A using the factorization A = U*D*U**T or */ -/* A = L*D*L**T computed by DSYTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the details of the factorization are stored */ -/* as an upper or lower triangular matrix. */ -/* = 'U': Upper triangular, form is A = U*D*U**T; */ -/* = 'L': Lower triangular, form is A = L*D*L**T. */ - -/* 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 block diagonal matrix D and the multipliers used to */ -/* obtain the factor U or L as computed by DSYTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSYTRF. */ - -/* 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 .. */ - - /* 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; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *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_("DSYTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B, where A = U*D*U'. */ - -/* First solve U*D*X = B, overwriting B with X. */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = *n; -L10: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L30; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(U(K)), where U(K) is the transformation */ -/* stored in column K of A. */ - - i__1 = k - 1; - dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + - b_dim1], ldb, &b[b_dim1 + 1], ldb); - -/* Multiply by the inverse of the diagonal block. */ - - d__1 = 1. / a[k + k * a_dim1]; - dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); - --k; - } else { - -/* 2 x 2 diagonal block */ - -/* Interchange rows K-1 and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k - 1) { - dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(U(K)), where U(K) is the transformation */ -/* stored in columns K-1 and K of A. */ - - i__1 = k - 2; - dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + - b_dim1], ldb, &b[b_dim1 + 1], ldb); - i__1 = k - 2; - dger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k - - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb); - -/* Multiply by the inverse of the diagonal block. */ - - akm1k = a[k - 1 + k * a_dim1]; - akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k; - ak = a[k + k * a_dim1] / akm1k; - denom = akm1 * ak - 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - bkm1 = b[k - 1 + j * b_dim1] / akm1k; - bk = b[k + j * b_dim1] / akm1k; - b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; - b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom; -/* L20: */ - } - k += -2; - } - - goto L10; -L30: - -/* Next solve U'*X = B, overwriting B with X. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; -L40: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L50; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Multiply by inv(U'(K)), where U(K) is the transformation */ -/* stored in column K of A. */ - - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * - a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - ++k; - } else { - -/* 2 x 2 diagonal block */ - -/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */ -/* stored in columns K and K+1 of A. */ - - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * - a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[(k - + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + b_dim1], - ldb); - -/* Interchange rows K and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - k += 2; - } - - goto L40; -L50: - - ; - } else { - -/* Solve A*X = B, where A = L*D*L'. */ - -/* First solve L*D*X = B, overwriting B with X. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; -L60: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L80; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(L(K)), where L(K) is the transformation */ -/* stored in column K of A. */ - - if (k < *n) { - i__1 = *n - k; - dger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k - + b_dim1], ldb, &b[k + 1 + b_dim1], ldb); - } - -/* Multiply by the inverse of the diagonal block. */ - - d__1 = 1. / a[k + k * a_dim1]; - dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); - ++k; - } else { - -/* 2 x 2 diagonal block */ - -/* Interchange rows K+1 and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k + 1) { - dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(L(K)), where L(K) is the transformation */ -/* stored in columns K and K+1 of A. */ - - if (k < *n - 1) { - i__1 = *n - k - 1; - dger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k - + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); - i__1 = *n - k - 1; - dger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1, - &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); - } - -/* Multiply by the inverse of the diagonal block. */ - - akm1k = a[k + 1 + k * a_dim1]; - akm1 = a[k + k * a_dim1] / akm1k; - ak = a[k + 1 + (k + 1) * a_dim1] / akm1k; - denom = akm1 * ak - 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - bkm1 = b[k + j * b_dim1] / akm1k; - bk = b[k + 1 + j * b_dim1] / akm1k; - b[k + j * b_dim1] = (ak * bkm1 - bk) / denom; - b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; -/* L70: */ - } - k += 2; - } - - goto L60; -L80: - -/* Next solve L'*X = B, overwriting B with X. */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = *n; -L90: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L100; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Multiply by inv(L'(K)), where L(K) is the transformation */ -/* stored in column K of A. */ - - if (k < *n) { - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + - b_dim1], ldb); - } - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - --k; - } else { - -/* 2 x 2 diagonal block */ - -/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */ -/* stored in columns K-1 and K of A. */ - - if (k < *n) { - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + - b_dim1], ldb); - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[ - k - 1 + b_dim1], ldb); - } - -/* Interchange rows K and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - k += -2; - } - - goto L90; -L100: - ; - } - - return 0; - -/* End of DSYTRS */ - -} /* dsytrs_ */ diff --git a/3rdparty/lapack/dtrmm.c b/3rdparty/lapack/dtrmm.c deleted file mode 100644 index d83838a..0000000 --- a/3rdparty/lapack/dtrmm.c +++ /dev/null @@ -1,453 +0,0 @@ -/* dtrmm.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 dtrmm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublereal *alpha, doublereal *a, integer * - lda, doublereal *b, integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, info; - doublereal temp; - logical lside; - extern logical lsame_(char *, char *); - integer nrowa; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - logical nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRMM performs one of the matrix-matrix operations */ - -/* B := alpha*op( A )*B, or B := alpha*B*op( A ), */ - -/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */ -/* non-unit, upper or lower triangular matrix and op( A ) is one of */ - -/* op( A ) = A or op( A ) = A'. */ - -/* Arguments */ -/* ========== */ - -/* SIDE - CHARACTER*1. */ -/* On entry, SIDE specifies whether op( A ) multiplies B from */ -/* the left or right as follows: */ - -/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */ - -/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */ - -/* Unchanged on exit. */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix A is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* 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. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit triangular */ -/* as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* M - INTEGER. */ -/* On entry, M specifies the number of rows of B. M must be at */ -/* least zero. */ -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the number of columns of B. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - DOUBLE PRECISION. */ -/* On entry, ALPHA specifies the scalar alpha. When alpha is */ -/* zero then A is not referenced and B need not be set before */ -/* entry. */ -/* Unchanged on exit. */ - -/* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */ -/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ -/* Before entry with UPLO = 'U' or 'u', the leading k by k */ -/* upper triangular part of the array A must contain the upper */ -/* triangular matrix and the strictly lower triangular part of */ -/* A is not referenced. */ -/* Before entry with UPLO = 'L' or 'l', the leading k by k */ -/* lower triangular part of the array A must contain the lower */ -/* triangular matrix and the strictly upper triangular part of */ -/* A is not referenced. */ -/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ -/* A are not referenced either, but are assumed to be unity. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ -/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ -/* then LDA must be at least max( 1, n ). */ -/* Unchanged on exit. */ - -/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */ -/* Before entry, the leading m by n part of the array B must */ -/* contain the matrix B, and on exit is overwritten by the */ -/* transformed matrix. */ - -/* LDB - INTEGER. */ -/* On entry, LDB specifies the first dimension of B as declared */ -/* in the calling (sub) program. LDB 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 .. */ -/* .. */ - -/* Test the input parameters. */ - - /* 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 */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < max(1,nrowa)) { - info = 9; - } else if (*ldb < max(1,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("DTRMM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - 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] = 0.; -/* L10: */ - } -/* L20: */ - } - return 0; - } - -/* Start the operations. */ - - if (lside) { - if (lsame_(transa, "N")) { - -/* Form B := alpha*A*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.) { - temp = *alpha * b[k + j * b_dim1]; - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * a[i__ + k * - a_dim1]; -/* L30: */ - } - if (nounit) { - temp *= a[k + k * a_dim1]; - } - b[k + j * b_dim1] = temp; - } -/* L40: */ - } -/* L50: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.) { - temp = *alpha * b[k + j * b_dim1]; - b[k + j * b_dim1] = temp; - if (nounit) { - b[k + j * b_dim1] *= a[k + k * a_dim1]; - } - i__2 = *m; - for (i__ = k + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * a[i__ + k * - a_dim1]; -/* L60: */ - } - } -/* L70: */ - } -/* L80: */ - } - } - } else { - -/* Form B := alpha*A'*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = b[i__ + j * b_dim1]; - if (nounit) { - temp *= a[i__ + i__ * a_dim1]; - } - i__2 = i__ - 1; - for (k = 1; k <= i__2; ++k) { - temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L90: */ - } - b[i__ + j * b_dim1] = *alpha * temp; -/* L100: */ - } -/* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = b[i__ + j * b_dim1]; - if (nounit) { - temp *= a[i__ + i__ * a_dim1]; - } - i__3 = *m; - for (k = i__ + 1; k <= i__3; ++k) { - temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L120: */ - } - b[i__ + j * b_dim1] = *alpha * temp; -/* L130: */ - } -/* L140: */ - } - } - } - } else { - if (lsame_(transa, "N")) { - -/* Form B := alpha*B*A. */ - - if (upper) { - for (j = *n; j >= 1; --j) { - temp = *alpha; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L150: */ - } - i__1 = j - 1; - for (k = 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.) { - temp = *alpha * a[k + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = *alpha; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L190: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.) { - temp = *alpha * a[k + j * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L200: */ - } - } -/* L210: */ - } -/* L220: */ - } - } - } else { - -/* Form B := alpha*B*A'. */ - - if (upper) { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - i__2 = k - 1; - for (j = 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = *alpha * a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L230: */ - } - } -/* L240: */ - } - temp = *alpha; - if (nounit) { - temp *= a[k + k * a_dim1]; - } - if (temp != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L250: */ - } - } -/* L260: */ - } - } else { - for (k = *n; k >= 1; --k) { - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = *alpha * a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L270: */ - } - } -/* L280: */ - } - temp = *alpha; - if (nounit) { - temp *= a[k + k * a_dim1]; - } - if (temp != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L290: */ - } - } -/* L300: */ - } - } - } - } - - return 0; - -/* End of DTRMM . */ - -} /* dtrmm_ */ diff --git a/3rdparty/lapack/dtrmv.c b/3rdparty/lapack/dtrmv.c deleted file mode 100644 index c9a0b12..0000000 --- a/3rdparty/lapack/dtrmv.c +++ /dev/null @@ -1,345 +0,0 @@ -/* dtrmv.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 dtrmv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, jx, kx, info; - doublereal temp; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - logical nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRMV performs one of the matrix-vector operations */ - -/* x := A*x, or x := A'*x, */ - -/* where x is an n element vector and A is an n by n unit, or non-unit, */ -/* upper or lower triangular matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' x := A*x. */ - -/* TRANS = 'T' or 't' x := A'*x. */ - -/* TRANS = 'C' or 'c' x := A'*x. */ - -/* Unchanged on exit. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit */ -/* triangular as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular matrix and the strictly lower triangular part of */ -/* A is not referenced. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular matrix and the strictly upper triangular part of */ -/* A is not referenced. */ -/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ -/* A are not referenced either, but are assumed to be unity. */ -/* 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, n ). */ -/* Unchanged on exit. */ - -/* X - DOUBLE PRECISION array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. On exit, X is overwritten with the */ -/* tranformed vector x. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX 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. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*lda < max(1,*n)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } - if (info != 0) { - xerbla_("DTRMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - nounit = lsame_(diag, "N"); - -/* Set up the start point in X if the increment is not unity. This */ -/* will be ( N - 1 )*INCX too small for descending loops. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N")) { - -/* Form x := A*x. */ - - if (lsame_(uplo, "U")) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__] += temp * a[i__ + j * a_dim1]; -/* L10: */ - } - if (nounit) { - x[j] *= a[j + j * a_dim1]; - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[ix] += temp * a[i__ + j * a_dim1]; - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= a[j + j * a_dim1]; - } - } - jx += *incx; -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[i__] += temp * a[i__ + j * a_dim1]; -/* L50: */ - } - if (nounit) { - x[j] *= a[j + j * a_dim1]; - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[ix] += temp * a[i__ + j * a_dim1]; - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= a[j + j * a_dim1]; - } - } - jx -= *incx; -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x. */ - - if (lsame_(uplo, "U")) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - for (i__ = j - 1; i__ >= 1; --i__) { - temp += a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - x[j] = temp; -/* L100: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - temp += a[i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[i__]; -/* L130: */ - } - x[j] = temp; -/* L140: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - temp += a[i__ + j * a_dim1] * x[ix]; -/* L150: */ - } - x[jx] = temp; - jx += *incx; -/* L160: */ - } - } - } - } - - return 0; - -/* End of DTRMV . */ - -} /* dtrmv_ */ diff --git a/3rdparty/lapack/dtrsm.c b/3rdparty/lapack/dtrsm.c deleted file mode 100644 index ba301fa..0000000 --- a/3rdparty/lapack/dtrsm.c +++ /dev/null @@ -1,490 +0,0 @@ -/* dtrsm.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 dtrsm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublereal *alpha, doublereal *a, integer * - lda, doublereal *b, integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, info; - doublereal temp; - logical lside; - extern logical lsame_(char *, char *); - integer nrowa; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - logical nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRSM solves one of the matrix equations */ - -/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ - -/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ -/* non-unit, upper or lower triangular matrix and op( A ) is one of */ - -/* op( A ) = A or op( A ) = A'. */ - -/* The matrix X is overwritten on B. */ - -/* Arguments */ -/* ========== */ - -/* SIDE - CHARACTER*1. */ -/* On entry, SIDE specifies whether op( A ) appears on the left */ -/* or right of X as follows: */ - -/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ - -/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ - -/* Unchanged on exit. */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix A is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* 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. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit triangular */ -/* as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* M - INTEGER. */ -/* On entry, M specifies the number of rows of B. M must be at */ -/* least zero. */ -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the number of columns of B. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - DOUBLE PRECISION. */ -/* On entry, ALPHA specifies the scalar alpha. When alpha is */ -/* zero then A is not referenced and B need not be set before */ -/* entry. */ -/* Unchanged on exit. */ - -/* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */ -/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ -/* Before entry with UPLO = 'U' or 'u', the leading k by k */ -/* upper triangular part of the array A must contain the upper */ -/* triangular matrix and the strictly lower triangular part of */ -/* A is not referenced. */ -/* Before entry with UPLO = 'L' or 'l', the leading k by k */ -/* lower triangular part of the array A must contain the lower */ -/* triangular matrix and the strictly upper triangular part of */ -/* A is not referenced. */ -/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ -/* A are not referenced either, but are assumed to be unity. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ -/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ -/* then LDA must be at least max( 1, n ). */ -/* Unchanged on exit. */ - -/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */ -/* Before entry, the leading m by n part of the array B must */ -/* contain the right-hand side matrix B, and on exit is */ -/* overwritten by the solution matrix X. */ - -/* LDB - INTEGER. */ -/* On entry, LDB specifies the first dimension of B as declared */ -/* in the calling (sub) program. LDB 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 .. */ -/* .. */ - -/* Test the input parameters. */ - - /* 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 */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < max(1,nrowa)) { - info = 9; - } else if (*ldb < max(1,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("DTRSM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - 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] = 0.; -/* L10: */ - } -/* L20: */ - } - return 0; - } - -/* Start the operations. */ - - if (lside) { - if (lsame_(transa, "N")) { - -/* Form B := alpha*inv( A )*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L30: */ - } - } - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__2 = k - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; -/* L40: */ - } - } -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L70: */ - } - } - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__3 = *m; - for (i__ = k + 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; -/* L80: */ - } - } -/* L90: */ - } -/* L100: */ - } - } - } else { - -/* Form B := alpha*inv( A' )*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L110: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L140: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; -/* L150: */ - } -/* L160: */ - } - } - } - } else { - if (lsame_(transa, "N")) { - -/* Form B := alpha*B*inv( A ). */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L170: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; -/* L180: */ - } - } -/* L190: */ - } - if (nounit) { - temp = 1. / a[j + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L200: */ - } - } -/* L210: */ - } - } else { - for (j = *n; j >= 1; --j) { - if (*alpha != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L220: */ - } - } - i__1 = *n; - for (k = j + 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; -/* L230: */ - } - } -/* L240: */ - } - if (nounit) { - temp = 1. / a[j + j * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L250: */ - } - } -/* L260: */ - } - } - } else { - -/* Form B := alpha*B*inv( A' ). */ - - if (upper) { - for (k = *n; k >= 1; --k) { - if (nounit) { - temp = 1. / a[k + k * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L270: */ - } - } - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; -/* L280: */ - } - } -/* L290: */ - } - if (*alpha != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; -/* L300: */ - } - } -/* L310: */ - } - } else { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (nounit) { - temp = 1. / a[k + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L320: */ - } - } - i__2 = *n; - for (j = k + 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; -/* L330: */ - } - } -/* L340: */ - } - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; -/* L350: */ - } - } -/* L360: */ - } - } - } - } - - return 0; - -/* End of DTRSM . */ - -} /* dtrsm_ */ diff --git a/3rdparty/lapack/dtrti2.c b/3rdparty/lapack/dtrti2.c deleted file mode 100644 index 3702993..0000000 --- a/3rdparty/lapack/dtrti2.c +++ /dev/null @@ -1,183 +0,0 @@ -/* dtrti2.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 dtrti2_(char *uplo, char *diag, integer *n, doublereal * - a, integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer j; - doublereal ajj; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - logical upper; - extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *); - logical nounit; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTI2 computes the inverse of a real upper or lower triangular */ -/* matrix. */ - -/* This is the Level 2 BLAS version of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular matrix A. If UPLO = 'U', the */ -/* leading n by n upper triangular part of the array A contains */ -/* the upper triangular matrix, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of the array A contains */ -/* the lower triangular matrix, and the strictly upper */ -/* triangular part of A is not referenced. If DIAG = 'U', the */ -/* diagonal elements of A are also not referenced and are */ -/* assumed to be 1. */ - -/* On exit, the (triangular) inverse of the original matrix, in */ -/* the same storage format. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTI2", &i__1); - return 0; - } - - if (upper) { - -/* Compute inverse of upper triangular matrix. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (nounit) { - a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; - ajj = -a[j + j * a_dim1]; - } else { - ajj = -1.; - } - -/* Compute elements 1:j-1 of j-th column. */ - - i__2 = j - 1; - dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, & - a[j * a_dim1 + 1], &c__1); - i__2 = j - 1; - dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); -/* L10: */ - } - } else { - -/* Compute inverse of lower triangular matrix. */ - - for (j = *n; j >= 1; --j) { - if (nounit) { - a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; - ajj = -a[j + j * a_dim1]; - } else { - ajj = -1.; - } - if (j < *n) { - -/* Compute elements j+1:n of j-th column. */ - - i__1 = *n - j; - dtrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j + - 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1); - i__1 = *n - j; - dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); - } -/* L20: */ - } - } - - return 0; - -/* End of DTRTI2 */ - -} /* dtrti2_ */ diff --git a/3rdparty/lapack/dtrtri.c b/3rdparty/lapack/dtrtri.c deleted file mode 100644 index 94553cc..0000000 --- a/3rdparty/lapack/dtrtri.c +++ /dev/null @@ -1,242 +0,0 @@ -/* dtrtri.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_b18 = 1.; -static doublereal c_b22 = -1.; - -/* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal * - a, integer *lda, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer j, jb, nb, nn; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *), dtrsm_( - char *, char *, char *, char *, integer *, integer *, doublereal * -, doublereal *, integer *, doublereal *, integer *); - logical upper; - extern /* Subroutine */ int dtrti2_(char *, char *, integer *, doublereal - *, integer *, integer *), xerbla_(char *, integer - *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - logical nounit; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTRI computes the inverse of a real upper or lower triangular */ -/* matrix A. */ - -/* This is the Level 3 BLAS version of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of the array A contains */ -/* the upper triangular matrix, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of the array A contains */ -/* the lower triangular matrix, and the strictly upper */ -/* triangular part of A is not referenced. If DIAG = 'U', the */ -/* diagonal elements of A are also not referenced and are */ -/* assumed to be 1. */ -/* On exit, the (triangular) inverse of the original matrix, in */ -/* the same storage format. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= 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, A(i,i) is exactly zero. The triangular */ -/* matrix is singular and its inverse can 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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity if non-unit. */ - - if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L10: */ - } - *info = 0; - } - -/* Determine the block size for this environment. */ - -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = uplo; - i__2[1] = 1, a__1[1] = diag; - s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); - nb = ilaenv_(&c__1, "DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - dtrti2_(uplo, diag, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute inverse of upper triangular matrix */ - - i__1 = *n; - i__3 = nb; - for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { -/* Computing MIN */ - i__4 = nb, i__5 = *n - j + 1; - jb = min(i__4,i__5); - -/* Compute rows 1:j-1 of current block column */ - - i__4 = j - 1; - dtrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, & - c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda); - i__4 = j - 1; - dtrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, & - c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], - lda); - -/* Compute inverse of current diagonal block */ - - dtrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info); -/* L20: */ - } - } else { - -/* Compute inverse of lower triangular matrix */ - - nn = (*n - 1) / nb * nb + 1; - i__3 = -nb; - for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { -/* Computing MIN */ - i__1 = nb, i__4 = *n - j + 1; - jb = min(i__1,i__4); - if (j + jb <= *n) { - -/* Compute rows j+jb:n of current block column */ - - i__1 = *n - j - jb + 1; - dtrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb, - &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j - + jb + j * a_dim1], lda); - i__1 = *n - j - jb + 1; - dtrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb, - &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j * - a_dim1], lda); - } - -/* Compute inverse of current diagonal block */ - - dtrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info); -/* L30: */ - } - } - } - - return 0; - -/* End of DTRTRI */ - -} /* dtrtri_ */ diff --git a/3rdparty/lapack/dtrtrs.c b/3rdparty/lapack/dtrtrs.c deleted file mode 100644 index abf72d6..0000000 --- a/3rdparty/lapack/dtrtrs.c +++ /dev/null @@ -1,183 +0,0 @@ -/* dtrtrs.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_b12 = 1.; - -/* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *a, integer *lda, 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 *); - logical nounit; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTRS solves a triangular system of the form */ - -/* A * X = B or A**T * X = B, */ - -/* where A is a triangular matrix of order N, and B is an N-by-NRHS */ -/* matrix. A check is made to verify that A is nonsingular. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* 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 triangular matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, if INFO = 0, 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 */ -/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ -/* indicating that the matrix is singular and the solutions */ -/* X have not been 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; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - nounit = lsame_(diag, "N"); - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*lda < max(1,*n)) { - *info = -7; - } else if (*ldb < max(1,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity. */ - - if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L10: */ - } - } - *info = 0; - -/* Solve A * x = b or A' * x = b. */ - - dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[ - b_offset], ldb); - - return 0; - -/* End of DTRTRS */ - -} /* dtrtrs_ */ diff --git a/3rdparty/lapack/f77_aloc.c b/3rdparty/lapack/f77_aloc.c deleted file mode 100644 index 9ebd5e9..0000000 --- a/3rdparty/lapack/f77_aloc.c +++ /dev/null @@ -1,22 +0,0 @@ -#include "clapack.h" -#undef abs -#undef min -#undef max -#include "stdio.h" - -static integer memfailure = 3; - -#include "stdlib.h" - -char* F77_aloc(integer Len, char *whence) -{ - char *rv; - unsigned int uLen = (unsigned int) Len; /* for K&R C */ - - if (!(rv = (char*)malloc(uLen))) { - fprintf(stderr, "malloc(%u) failure in %s\n", - uLen, whence); - exit_(&memfailure); - } - return rv; -} diff --git a/3rdparty/lapack/idamax.c b/3rdparty/lapack/idamax.c deleted file mode 100644 index 104ad50..0000000 --- a/3rdparty/lapack/idamax.c +++ /dev/null @@ -1,93 +0,0 @@ -/* idamax.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 idamax_(integer *n, doublereal *dx, integer *incx) -{ - /* System generated locals */ - integer ret_val, i__1; - doublereal d__1; - - /* Local variables */ - integer i__, ix; - doublereal dmax__; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* finds the index of element having max. absolute value. */ -/* 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; - if (*n < 1 || *incx <= 0) { - return ret_val; - } - ret_val = 1; - if (*n == 1) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - ix = 1; - dmax__ = abs(dx[1]); - ix += *incx; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((d__1 = dx[ix], abs(d__1)) <= dmax__) { - goto L5; - } - ret_val = i__; - dmax__ = (d__1 = dx[ix], abs(d__1)); -L5: - ix += *incx; -/* L10: */ - } - return ret_val; - -/* code for increment equal to 1 */ - -L20: - dmax__ = abs(dx[1]); - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((d__1 = dx[i__], abs(d__1)) <= dmax__) { - goto L30; - } - ret_val = i__; - dmax__ = (d__1 = dx[i__], abs(d__1)); -L30: - ; - } - return ret_val; -} /* idamax_ */ diff --git a/3rdparty/lapack/ieeeck.c b/3rdparty/lapack/ieeeck.c deleted file mode 100644 index 404ebba..0000000 --- a/3rdparty/lapack/ieeeck.c +++ /dev/null @@ -1,166 +0,0 @@ -/* ieeeck.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 ieeeck_(integer *ispec, real *zero, real *one) -{ - /* System generated locals */ - integer ret_val; - - /* Local variables */ - real nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* IEEECK is called from the ILAENV to verify that Infinity and */ -/* possibly NaN arithmetic is safe (i.e. will not trap). */ - -/* Arguments */ -/* ========= */ - -/* ISPEC (input) INTEGER */ -/* Specifies whether to test just for inifinity arithmetic */ -/* or whether to test for infinity and NaN arithmetic. */ -/* = 0: Verify infinity arithmetic only. */ -/* = 1: Verify infinity and NaN arithmetic. */ - -/* ZERO (input) REAL */ -/* Must contain the value 0.0 */ -/* This is passed to prevent the compiler from optimizing */ -/* away this code. */ - -/* ONE (input) REAL */ -/* Must contain the value 1.0 */ -/* This is passed to prevent the compiler from optimizing */ -/* away this code. */ - -/* RETURN VALUE: INTEGER */ -/* = 0: Arithmetic failed to produce the correct answers */ -/* = 1: Arithmetic produced the correct answers */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - ret_val = 1; - - posinf = *one / *zero; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - neginf = -(*one) / *zero; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - negzro = *one / (neginf + *one); - if (negzro != *zero) { - ret_val = 0; - return ret_val; - } - - neginf = *one / negzro; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - newzro = negzro + *zero; - if (newzro != *zero) { - ret_val = 0; - return ret_val; - } - - posinf = *one / newzro; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - neginf *= posinf; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - posinf *= posinf; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - - - -/* Return if we were only asked to check infinity arithmetic */ - - if (*ispec == 0) { - return ret_val; - } - - nan1 = posinf + neginf; - - nan2 = posinf / neginf; - - nan3 = posinf / posinf; - - nan4 = posinf * *zero; - - nan5 = neginf * negzro; - - nan6 = nan5 * 0.f; - - if (nan1 == nan1) { - ret_val = 0; - return ret_val; - } - - if (nan2 == nan2) { - ret_val = 0; - return ret_val; - } - - if (nan3 == nan3) { - ret_val = 0; - return ret_val; - } - - if (nan4 == nan4) { - ret_val = 0; - return ret_val; - } - - if (nan5 == nan5) { - ret_val = 0; - return ret_val; - } - - if (nan6 == nan6) { - ret_val = 0; - return ret_val; - } - - return ret_val; -} /* ieeeck_ */ diff --git a/3rdparty/lapack/iladlc.c b/3rdparty/lapack/iladlc.c deleted file mode 100644 index 34eee96..0000000 --- a/3rdparty/lapack/iladlc.c +++ /dev/null @@ -1,88 +0,0 @@ -/* iladlc.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 iladlc_(integer *m, integer *n, doublereal *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, ret_val, i__1; - - /* Local variables */ - integer i__; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ - -/* -- April 2009 -- */ - -/* -- 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 */ -/* ======= */ - -/* ILADLC scans A for its last non-zero column. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* 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(1,M). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick test for the common case where one corner is non-zero. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - if (*n == 0) { - ret_val = *n; - } else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) { - ret_val = *n; - } else { -/* Now scan each column from the end, returning with the first non-zero. */ - for (ret_val = *n; ret_val >= 1; --ret_val) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (a[i__ + ret_val * a_dim1] != 0.) { - return ret_val; - } - } - } - } - return ret_val; -} /* iladlc_ */ diff --git a/3rdparty/lapack/iladlr.c b/3rdparty/lapack/iladlr.c deleted file mode 100644 index 1e6e00f..0000000 --- a/3rdparty/lapack/iladlr.c +++ /dev/null @@ -1,90 +0,0 @@ -/* iladlr.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 iladlr_(integer *m, integer *n, doublereal *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, ret_val, i__1; - - /* Local variables */ - integer i__, j; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ - -/* -- April 2009 -- */ - -/* -- 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 */ -/* ======= */ - -/* ILADLR scans A for its last non-zero row. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* 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(1,M). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick test for the common case where one corner is non-zero. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - if (*m == 0) { - ret_val = *m; - } else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) { - ret_val = *m; - } else { -/* Scan up each column tracking the last zero row seen. */ - ret_val = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - if (a[i__ + j * a_dim1] != 0.) { - break; - } - } - ret_val = max(ret_val,i__); - } - } - return ret_val; -} /* iladlr_ */ diff --git a/3rdparty/lapack/ilaenv_custom.c b/3rdparty/lapack/ilaenv_custom.c deleted file mode 100644 index e58833f..0000000 --- a/3rdparty/lapack/ilaenv_custom.c +++ /dev/null @@ -1,191 +0,0 @@ -/* ilaenv.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" - -#include "string.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static real c_b163 = 0.f; -static real c_b164 = 1.f; -static integer c__0 = 0; - -integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, - integer *n2, integer *n3, integer *n4) -{ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* January 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* ILAENV is called from the LAPACK routines to choose problem-dependent */ -/* parameters for the local environment. See ISPEC for a description of */ -/* the parameters. */ - -/* ILAENV returns an INTEGER */ -/* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC */ -/* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. */ - -/* This version provides a set of parameters which should give good, */ -/* but not optimal, performance on many of the currently available */ -/* computers. Users are encouraged to modify this subroutine to set */ -/* the tuning parameters for their particular machine using the option */ -/* and problem size information in the arguments. */ - -/* This routine will not function correctly if it is converted to all */ -/* lower case. Converting it to all upper case is allowed. */ - -/* Arguments */ -/* ========= */ - -/* ISPEC (input) INTEGER */ -/* Specifies the parameter to be returned as the value of */ -/* ILAENV. */ -/* = 1: the optimal blocksize; if this value is 1, an unblocked */ -/* algorithm will give the best performance. */ -/* = 2: the minimum block size for which the block routine */ -/* should be used; if the usable block size is less than */ -/* this value, an unblocked routine should be used. */ -/* = 3: the crossover point (in a block routine, for N less */ -/* than this value, an unblocked routine should be used) */ -/* = 4: the number of shifts, used in the nonsymmetric */ -/* eigenvalue routines (DEPRECATED) */ -/* = 5: the minimum column dimension for blocking to be used; */ -/* rectangular blocks must have dimension at least k by m, */ -/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */ -/* = 6: the crossover point for the SVD (when reducing an m by n */ -/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */ -/* this value, a QR factorization is used first to reduce */ -/* the matrix to a triangular form.) */ -/* = 7: the number of processors */ -/* = 8: the crossover point for the multishift QR method */ -/* for nonsymmetric eigenvalue problems (DEPRECATED) */ -/* = 9: maximum size of the subproblems at the bottom of the */ -/* computation tree in the divide-and-conquer algorithm */ -/* (used by xGELSD and xGESDD) */ -/* =10: ieee NaN arithmetic can be trusted not to trap */ -/* =11: infinity arithmetic can be trusted not to trap */ -/* 12 <= ISPEC <= 16: */ -/* xHSEQR or one of its subroutines, */ -/* see IPARMQ for detailed explanation */ - -/* NAME (input) CHARACTER*(*) */ -/* The name of the calling subroutine, in either upper case or */ -/* lower case. */ - -/* OPTS (input) CHARACTER*(*) */ -/* The character options to the subroutine NAME, concatenated */ -/* into a single character string. For example, UPLO = 'U', */ -/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */ -/* be specified as OPTS = 'UTN'. */ - -/* N1 (input) INTEGER */ -/* N2 (input) INTEGER */ -/* N3 (input) INTEGER */ -/* N4 (input) INTEGER */ -/* Problem dimensions for the subroutine NAME; these may not all */ -/* be required. */ - -/* Further Details */ -/* =============== */ - -/* The following conventions have been used when calling ILAENV from the */ -/* LAPACK routines: */ -/* 1) OPTS is a concatenation of all of the character options to */ -/* subroutine NAME, in the same order that they appear in the */ -/* argument list for NAME, even if they are not used in determining */ -/* the value of the parameter specified by ISPEC. */ -/* 2) The problem dimensions N1, N2, N3, N4 are specified in the order */ -/* that they appear in the argument list for NAME. N1 is used */ -/* first, N2 second, and so on, and unused problem dimensions are */ -/* passed a value of -1. */ -/* 3) The parameter value returned by ILAENV is checked for validity in */ -/* the calling subroutine. For example, ILAENV is used to retrieve */ -/* the optimal blocksize for STRTRI as follows: */ - -/* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */ -/* IF( NB.LE.1 ) NB = MAX( 1, N ) */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - switch (*ispec) { - case 1: - /* ISPEC = 1: block size */ - - /* In these examples, separate code is provided for setting NB for */ - /* real and complex. We assume that NB will take the same value in */ - /* single or double precision. */ - return 1; - case 2: - /* ISPEC = 2: minimum block size */ - return 2; - case 3: - /* ISPEC = 3: crossover point */ - return 3; - case 4: - /* ISPEC = 4: number of shifts (used by xHSEQR) */ - return 6; - case 5: - /* ISPEC = 5: minimum column dimension (not used) */ - return 2; - case 6: - /* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */ - return (integer) ((real) min(*n1,*n2) * 1.6f); - case 7: - /* ISPEC = 7: number of processors (not used) */ - return 1; - case 8: - /* ISPEC = 8: crossover point for multishift (used by xHSEQR) */ - return 50; - case 9: - /* ISPEC = 9: maximum size of the subproblems at the bottom of the */ - /* computation tree in the divide-and-conquer algorithm */ - /* (used by xGELSD and xGESDD) */ - return 25; - case 10: - /* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */ - return ieeeck_(&c__1, &c_b163, &c_b164); - case 11: - /* ISPEC = 11: infinity arithmetic can be trusted not to trap */ - return ieeeck_(&c__0, &c_b163, &c_b164); - case 12: - case 13: - case 14: - case 15: - case 16: - /* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. */ - return iparmq_(ispec, name__, opts, n1, n2, n3, n4); - default: - break; - } - - /* Invalid value for ISPEC */ - return -1; - -/* End of ILAENV */ - -} /* ilaenv_ */ diff --git a/3rdparty/lapack/ilaslc.c b/3rdparty/lapack/ilaslc.c deleted file mode 100644 index e057453..0000000 --- a/3rdparty/lapack/ilaslc.c +++ /dev/null @@ -1,88 +0,0 @@ -/* ilaslc.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 ilaslc_(integer *m, integer *n, real *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, ret_val, i__1; - - /* Local variables */ - integer i__; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ - -/* -- April 2009 -- */ - -/* -- 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 */ -/* ======= */ - -/* ILASLC scans A for its last non-zero column. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* A (input) REAL array, dimension (LDA,N) */ -/* The m by n matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick test for the common case where one corner is non-zero. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - if (*n == 0) { - ret_val = *n; - } else if (a[*n * a_dim1 + 1] != 0.f || a[*m + *n * a_dim1] != 0.f) { - ret_val = *n; - } else { -/* Now scan each column from the end, returning with the first non-zero. */ - for (ret_val = *n; ret_val >= 1; --ret_val) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (a[i__ + ret_val * a_dim1] != 0.f) { - return ret_val; - } - } - } - } - return ret_val; -} /* ilaslc_ */ diff --git a/3rdparty/lapack/ilaslr.c b/3rdparty/lapack/ilaslr.c deleted file mode 100644 index b0fa274..0000000 --- a/3rdparty/lapack/ilaslr.c +++ /dev/null @@ -1,90 +0,0 @@ -/* ilaslr.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 ilaslr_(integer *m, integer *n, real *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, ret_val, i__1; - - /* Local variables */ - integer i__, j; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ - -/* -- April 2009 -- */ - -/* -- 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 */ -/* ======= */ - -/* ILASLR scans A for its last non-zero row. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* A (input) REAL array, dimension (LDA,N) */ -/* The m by n matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick test for the common case where one corner is non-zero. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - if (*m == 0) { - ret_val = *m; - } else if (a[*m + a_dim1] != 0.f || a[*m + *n * a_dim1] != 0.f) { - ret_val = *m; - } else { -/* Scan up each column tracking the last zero row seen. */ - ret_val = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - if (a[i__ + j * a_dim1] != 0.f) { - break; - } - } - ret_val = max(ret_val,i__); - } - } - return ret_val; -} /* ilaslr_ */ diff --git a/3rdparty/lapack/iparmq.c b/3rdparty/lapack/iparmq.c deleted file mode 100644 index abc4036..0000000 --- a/3rdparty/lapack/iparmq.c +++ /dev/null @@ -1,282 +0,0 @@ -/* iparmq.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 iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer - *ilo, integer *ihi, integer *lwork) -{ - /* System generated locals */ - integer ret_val, i__1, i__2; - real r__1; - - /* Builtin functions */ - double log(doublereal); - integer i_nint(real *); - - /* Local variables */ - integer nh, ns; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ - -/* Purpose */ -/* ======= */ - -/* This program sets problem and machine dependent parameters */ -/* useful for xHSEQR and its subroutines. It is called whenever */ -/* ILAENV is called with 12 <= ISPEC <= 16 */ - -/* Arguments */ -/* ========= */ - -/* ISPEC (input) integer scalar */ -/* ISPEC specifies which tunable parameter IPARMQ should */ -/* return. */ - -/* ISPEC=12: (INMIN) Matrices of order nmin or less */ -/* are sent directly to xLAHQR, the implicit */ -/* double shift QR algorithm. NMIN must be */ -/* at least 11. */ - -/* ISPEC=13: (INWIN) Size of the deflation window. */ -/* This is best set greater than or equal to */ -/* the number of simultaneous shifts NS. */ -/* Larger matrices benefit from larger deflation */ -/* windows. */ - -/* ISPEC=14: (INIBL) Determines when to stop nibbling and */ -/* invest in an (expensive) multi-shift QR sweep. */ -/* If the aggressive early deflation subroutine */ -/* finds LD converged eigenvalues from an order */ -/* NW deflation window and LD.GT.(NW*NIBBLE)/100, */ -/* then the next QR sweep is skipped and early */ -/* deflation is applied immediately to the */ -/* remaining active diagonal block. Setting */ -/* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a */ -/* multi-shift QR sweep whenever early deflation */ -/* finds a converged eigenvalue. Setting */ -/* IPARMQ(ISPEC=14) greater than or equal to 100 */ -/* prevents TTQRE from skipping a multi-shift */ -/* QR sweep. */ - -/* ISPEC=15: (NSHFTS) The number of simultaneous shifts in */ -/* a multi-shift QR iteration. */ - -/* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the */ -/* following meanings. */ -/* 0: During the multi-shift QR sweep, */ -/* xLAQR5 does not accumulate reflections and */ -/* does not use matrix-matrix multiply to */ -/* update the far-from-diagonal matrix */ -/* entries. */ -/* 1: During the multi-shift QR sweep, */ -/* xLAQR5 and/or xLAQRaccumulates reflections and uses */ -/* matrix-matrix multiply to update the */ -/* far-from-diagonal matrix entries. */ -/* 2: During the multi-shift QR sweep. */ -/* xLAQR5 accumulates reflections and takes */ -/* advantage of 2-by-2 block structure during */ -/* matrix-matrix multiplies. */ -/* (If xTRMM is slower than xGEMM, then */ -/* IPARMQ(ISPEC=16)=1 may be more efficient than */ -/* IPARMQ(ISPEC=16)=2 despite the greater level of */ -/* arithmetic work implied by the latter choice.) */ - -/* NAME (input) character string */ -/* Name of the calling subroutine */ - -/* OPTS (input) character string */ -/* This is a concatenation of the string arguments to */ -/* TTQRE. */ - -/* N (input) integer scalar */ -/* N is the order of the Hessenberg matrix H. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* It is assumed that H is already upper triangular */ -/* in rows and columns 1:ILO-1 and IHI+1:N. */ - -/* LWORK (input) integer scalar */ -/* The amount of workspace available. */ - -/* Further Details */ -/* =============== */ - -/* Little is known about how best to choose these parameters. */ -/* It is possible to use different values of the parameters */ -/* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. */ - -/* It is probably best to choose different parameters for */ -/* different matrices and different parameters at different */ -/* times during the iteration, but this has not been */ -/* implemented --- yet. */ - - -/* The best choices of most of the parameters depend */ -/* in an ill-understood way on the relative execution */ -/* rate of xLAQR3 and xLAQR5 and on the nature of each */ -/* particular eigenvalue problem. Experiment may be the */ -/* only practical way to determine which choices are most */ -/* effective. */ - -/* Following is a list of default values supplied by IPARMQ. */ -/* These defaults may be adjusted in order to attain better */ -/* performance in any particular computational environment. */ - -/* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. */ -/* Default: 75. (Must be at least 11.) */ - -/* IPARMQ(ISPEC=13) Recommended deflation window size. */ -/* This depends on ILO, IHI and NS, the */ -/* number of simultaneous shifts returned */ -/* by IPARMQ(ISPEC=15). The default for */ -/* (IHI-ILO+1).LE.500 is NS. The default */ -/* for (IHI-ILO+1).GT.500 is 3*NS/2. */ - -/* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. */ - -/* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. */ -/* a multi-shift QR iteration. */ - -/* If IHI-ILO+1 is ... */ - -/* greater than ...but less ... the */ -/* or equal to ... than default is */ - -/* 0 30 NS = 2+ */ -/* 30 60 NS = 4+ */ -/* 60 150 NS = 10 */ -/* 150 590 NS = ** */ -/* 590 3000 NS = 64 */ -/* 3000 6000 NS = 128 */ -/* 6000 infinity NS = 256 */ - -/* (+) By default matrices of this order are */ -/* passed to the implicit double shift routine */ -/* xLAHQR. See IPARMQ(ISPEC=12) above. These */ -/* values of NS are used only in case of a rare */ -/* xLAHQR failure. */ - -/* (**) The asterisks (**) indicate an ad-hoc */ -/* function increasing from 10 to 64. */ - -/* IPARMQ(ISPEC=16) Select structured matrix multiply. */ -/* (See ISPEC=16 above for details.) */ -/* Default: 3. */ - -/* ================================================================ */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - if (*ispec == 15 || *ispec == 13 || *ispec == 16) { - -/* ==== Set the number simultaneous shifts ==== */ - - nh = *ihi - *ilo + 1; - ns = 2; - if (nh >= 30) { - ns = 4; - } - if (nh >= 60) { - ns = 10; - } - if (nh >= 150) { -/* Computing MAX */ - r__1 = log((real) nh) / log(2.f); - i__1 = 10, i__2 = nh / i_nint(&r__1); - ns = max(i__1,i__2); - } - if (nh >= 590) { - ns = 64; - } - if (nh >= 3000) { - ns = 128; - } - if (nh >= 6000) { - ns = 256; - } -/* Computing MAX */ - i__1 = 2, i__2 = ns - ns % 2; - ns = max(i__1,i__2); - } - - if (*ispec == 12) { - - -/* ===== Matrices of order smaller than NMIN get sent */ -/* . to xLAHQR, the classic double shift algorithm. */ -/* . This must be at least 11. ==== */ - - ret_val = 75; - - } else if (*ispec == 14) { - -/* ==== INIBL: skip a multi-shift qr iteration and */ -/* . whenever aggressive early deflation finds */ -/* . at least (NIBBLE*(window size)/100) deflations. ==== */ - - ret_val = 14; - - } else if (*ispec == 15) { - -/* ==== NSHFTS: The number of simultaneous shifts ===== */ - - ret_val = ns; - - } else if (*ispec == 13) { - -/* ==== NW: deflation window size. ==== */ - - if (nh <= 500) { - ret_val = ns; - } else { - ret_val = ns * 3 / 2; - } - - } else if (*ispec == 16) { - -/* ==== IACC22: Whether to accumulate reflections */ -/* . before updating the far-from-diagonal elements */ -/* . and whether to use 2-by-2 block structure while */ -/* . doing it. A small amount of work could be saved */ -/* . by making this choice dependent also upon the */ -/* . NH=IHI-ILO+1. */ - - ret_val = 0; - if (ns >= 14) { - ret_val = 1; - } - if (ns >= 14) { - ret_val = 2; - } - - } else { -/* ===== invalid value of ispec ===== */ - ret_val = -1; - - } - -/* ==== End of IPARMQ ==== */ - - return ret_val; -} /* iparmq_ */ diff --git a/3rdparty/lapack/isamax.c b/3rdparty/lapack/isamax.c deleted file mode 100644 index bf17812..0000000 --- a/3rdparty/lapack/isamax.c +++ /dev/null @@ -1,93 +0,0 @@ -/* isamax.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 isamax_(integer *n, real *sx, integer *incx) -{ - /* System generated locals */ - integer ret_val, i__1; - real r__1; - - /* Local variables */ - integer i__, ix; - real smax; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* finds the index of element having max. absolute value. */ -/* 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 */ - --sx; - - /* Function Body */ - ret_val = 0; - if (*n < 1 || *incx <= 0) { - return ret_val; - } - ret_val = 1; - if (*n == 1) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - ix = 1; - smax = dabs(sx[1]); - ix += *incx; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((r__1 = sx[ix], dabs(r__1)) <= smax) { - goto L5; - } - ret_val = i__; - smax = (r__1 = sx[ix], dabs(r__1)); -L5: - ix += *incx; -/* L10: */ - } - return ret_val; - -/* code for increment equal to 1 */ - -L20: - smax = dabs(sx[1]); - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((r__1 = sx[i__], dabs(r__1)) <= smax) { - goto L30; - } - ret_val = i__; - smax = (r__1 = sx[i__], dabs(r__1)); -L30: - ; - } - return ret_val; -} /* isamax_ */ diff --git a/3rdparty/lapack/pow_di.c b/3rdparty/lapack/pow_di.c deleted file mode 100644 index d0e054b..0000000 --- a/3rdparty/lapack/pow_di.c +++ /dev/null @@ -1,31 +0,0 @@ -#include "clapack.h" - -double pow_di(doublereal *ap, integer *bp) -{ - double pow, x; - integer n; - unsigned long u; - - pow = 1; - x = *ap; - n = *bp; - - if(n != 0) - { - if(n < 0) - { - n = -n; - x = 1/x; - } - for(u = n; ; ) - { - if(u & 01) - pow *= x; - if(u >>= 1) - x *= x; - else - break; - } - } - return(pow); -} diff --git a/3rdparty/lapack/pow_ii.c b/3rdparty/lapack/pow_ii.c deleted file mode 100644 index c3ae4f3..0000000 --- a/3rdparty/lapack/pow_ii.c +++ /dev/null @@ -1,27 +0,0 @@ -#include "clapack.h" - -integer pow_ii(integer *ap, integer *bp) -{ - integer pow, x, n; - unsigned long u; - - x = *ap; - n = *bp; - - if (n <= 0) { - if (n == 0 || x == 1) - return 1; - return x != -1 ? 0 : (n & 1) ? -1 : 1; - } - u = n; - for(pow = 1; ; ) - { - if(u & 01) - pow *= x; - if(u >>= 1) - x *= x; - else - break; - } - return(pow); -} diff --git a/3rdparty/lapack/pow_ri.c b/3rdparty/lapack/pow_ri.c deleted file mode 100644 index d291ed1..0000000 --- a/3rdparty/lapack/pow_ri.c +++ /dev/null @@ -1,31 +0,0 @@ -#include "clapack.h" - -double pow_ri(real *ap, integer *bp) -{ - double pow, x; - integer n; - unsigned long u; - - pow = 1; - x = *ap; - n = *bp; - - if(n != 0) - { - if(n < 0) - { - n = -n; - x = 1/x; - } - for(u = n; ; ) - { - if(u & 01) - pow *= x; - if(u >>= 1) - x *= x; - else - break; - } - } - return(pow); -} diff --git a/3rdparty/lapack/precomp.c b/3rdparty/lapack/precomp.c deleted file mode 100644 index 39aadc9..0000000 --- a/3rdparty/lapack/precomp.c +++ /dev/null @@ -1 +0,0 @@ -#include "clapack.h" diff --git a/3rdparty/lapack/s_cat.c b/3rdparty/lapack/s_cat.c deleted file mode 100644 index d4294f6..0000000 --- a/3rdparty/lapack/s_cat.c +++ /dev/null @@ -1,57 +0,0 @@ -/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the - * target of a concatenation to appear on its right-hand side (contrary - * to the Fortran 77 Standard, but in accordance with Fortran 90). - */ - -#include "clapack.h" -#include "stdio.h" -#undef abs -#undef min -#undef max -#include "stdlib.h" -#include "string.h" - -void s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) -{ - ftnlen i, nc; - char *rp; - ftnlen n = *np; - ftnlen L, m; - char *lp0, *lp1; - - lp0 = 0; - lp1 = lp; - L = ll; - i = 0; - while(i < n) { - rp = rpp[i]; - m = rnp[i++]; - if (rp >= lp1 || rp + m <= lp) { - if ((L -= m) <= 0) { - n = i; - break; - } - lp1 += m; - continue; - } - lp0 = lp; - lp = lp1 = F77_aloc(L = ll, "s_cat"); - break; - } - lp1 = lp; - for(i = 0 ; i < n ; ++i) { - nc = ll; - if(rnp[i] < nc) - nc = rnp[i]; - ll -= nc; - rp = rpp[i]; - while(--nc >= 0) - *lp++ = *rp++; - } - while(--ll >= 0) - *lp++ = ' '; - if (lp0) { - memcpy(lp0, lp1, L); - free(lp1); - } -} diff --git a/3rdparty/lapack/s_cmp.c b/3rdparty/lapack/s_cmp.c deleted file mode 100644 index da33019..0000000 --- a/3rdparty/lapack/s_cmp.c +++ /dev/null @@ -1,40 +0,0 @@ -#include "clapack.h" - -/* compare two strings */ - -integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) -{ -register unsigned char *a, *aend, *b, *bend; -a = (unsigned char *)a0; -b = (unsigned char *)b0; -aend = a + la; -bend = b + lb; - -if(la <= lb) - { - while(a < aend) - if(*a != *b) - return( *a - *b ); - else - { ++a; ++b; } - - while(b < bend) - if(*b != ' ') - return( ' ' - *b ); - else ++b; - } - -else - { - while(b < bend) - if(*a == *b) - { ++a; ++b; } - else - return( *a - *b ); - while(a < aend) - if(*a != ' ') - return(*a - ' '); - else ++a; - } -return(0); -} diff --git a/3rdparty/lapack/s_copy.c b/3rdparty/lapack/s_copy.c deleted file mode 100644 index 26f223f..0000000 --- a/3rdparty/lapack/s_copy.c +++ /dev/null @@ -1,38 +0,0 @@ -/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the - * target of an assignment to appear on its right-hand side (contrary - * to the Fortran 77 Standard, but in accordance with Fortran 90), - * as in a(2:5) = a(4:7) . - */ - -#include "clapack.h" - -/* assign strings: a = b */ - -void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) -{ - register char *aend, *bend; - - aend = a + la; - - if(la <= lb) - if (a <= b || a >= b + la) - while(a < aend) - *a++ = *b++; - else - for(b += la; a < aend; ) - *--aend = *--b; - else { - bend = b + lb; - if (a <= b || a >= bend) - while(b < bend) - *a++ = *b++; - else { - a += lb; - while(b < bend) - *--a = *--bend; - a += lb; - } - while(a < aend) - *a++ = ' '; - } -} diff --git a/3rdparty/lapack/sasum.c b/3rdparty/lapack/sasum.c deleted file mode 100644 index 2fd9efa..0000000 --- a/3rdparty/lapack/sasum.c +++ /dev/null @@ -1,101 +0,0 @@ -/* sasum.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 sasum_(integer *n, real *sx, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - real ret_val, r__1, r__2, r__3, r__4, r__5, r__6; - - /* Local variables */ - integer i__, m, mp1, nincx; - real stemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* takes the sum of the absolute values. */ -/* uses unrolled loops for increment equal to one. */ -/* 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 */ - --sx; - - /* Function Body */ - ret_val = 0.f; - stemp = 0.f; - 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) { - stemp += (r__1 = sx[i__], dabs(r__1)); -/* L10: */ - } - ret_val = stemp; - 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__) { - stemp += (r__1 = sx[i__], dabs(r__1)); -/* L30: */ - } - if (*n < 6) { - goto L60; - } -L40: - mp1 = m + 1; - i__2 = *n; - for (i__ = mp1; i__ <= i__2; i__ += 6) { - stemp = stemp + (r__1 = sx[i__], dabs(r__1)) + (r__2 = sx[i__ + 1], - dabs(r__2)) + (r__3 = sx[i__ + 2], dabs(r__3)) + (r__4 = sx[ - i__ + 3], dabs(r__4)) + (r__5 = sx[i__ + 4], dabs(r__5)) + ( - r__6 = sx[i__ + 5], dabs(r__6)); -/* L50: */ - } -L60: - ret_val = stemp; - return ret_val; -} /* sasum_ */ diff --git a/3rdparty/lapack/saxpy.c b/3rdparty/lapack/saxpy.c deleted file mode 100644 index 3a48bb8..0000000 --- a/3rdparty/lapack/saxpy.c +++ /dev/null @@ -1,107 +0,0 @@ -/* saxpy.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 saxpy_(integer *n, real *sa, real *sx, integer *incx, - real *sy, integer *incy) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SAXPY constant times a vector plus a vector. */ -/* uses unrolled loop 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 */ - --sy; - --sx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*sa == 0.f) { - 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__) { - sy[iy] += *sa * sx[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__) { - sy[i__] += *sa * sx[i__]; -/* L30: */ - } - if (*n < 4) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 4) { - sy[i__] += *sa * sx[i__]; - sy[i__ + 1] += *sa * sx[i__ + 1]; - sy[i__ + 2] += *sa * sx[i__ + 2]; - sy[i__ + 3] += *sa * sx[i__ + 3]; -/* L50: */ - } - return 0; -} /* saxpy_ */ diff --git a/3rdparty/lapack/sbdsdc.c b/3rdparty/lapack/sbdsdc.c deleted file mode 100644 index 0f383d9..0000000 --- a/3rdparty/lapack/sbdsdc.c +++ /dev/null @@ -1,511 +0,0 @@ -/* sbdsdc.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 real c_b15 = 1.f; -static integer c__1 = 1; -static real c_b29 = 0.f; - -/* Subroutine */ int sbdsdc_(char *uplo, char *compq, integer *n, real *d__, - real *e, real *u, integer *ldu, real *vt, integer *ldvt, real *q, - integer *iq, real *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; - real r__1; - - /* Builtin functions */ - double r_sign(real *, real *), log(doublereal); - - /* Local variables */ - integer i__, j, k; - real p, r__; - integer z__, ic, ii, kk; - real cs; - integer is, iu; - real sn; - integer nm1; - real eps; - integer ivt, difl, difr, ierr, perm, mlvl, sqre; - extern logical lsame_(char *, char *); - integer poles; - extern /* Subroutine */ int slasr_(char *, char *, char *, integer *, - integer *, real *, real *, real *, integer *); - integer iuplo, nsize, start; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), sswap_(integer *, real *, integer *, real *, integer * -), slasd0_(integer *, integer *, real *, real *, real *, integer * -, real *, integer *, integer *, integer *, real *, integer *); - extern doublereal slamch_(char *); - extern /* Subroutine */ int slasda_(integer *, integer *, integer *, - integer *, real *, real *, real *, integer *, real *, integer *, - real *, real *, real *, real *, integer *, integer *, integer *, - integer *, real *, real *, real *, real *, integer *, integer *), - xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, - real *, integer *, integer *, real *, integer *, integer *); - integer givcol; - extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer - *, integer *, integer *, real *, real *, real *, integer *, real * -, integer *, real *, integer *, real *, integer *); - integer icompq; - extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, - real *, real *, integer *), slartg_(real *, real *, real * -, real *, real *); - real orgnrm; - integer givnum; - extern doublereal slanst_(char *, integer *, real *, real *); - integer 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 */ -/* ======= */ - -/* SBDSDC 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. SBDSDC 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 SLASD3 for details. */ - -/* The code currently calls SLASDQ 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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 REAL 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) REAL 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_("SBDSDC", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - smlsiz = ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0); - if (*n == 1) { - if (icompq == 1) { - q[1] = r_sign(&c_b15, &d__[1]); - q[smlsiz * *n + 1] = 1.f; - } else if (icompq == 2) { - u[u_dim1 + 1] = r_sign(&c_b15, &d__[1]); - vt[vt_dim1 + 1] = 1.f; - } - d__[1] = dabs(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) { - scopy_(n, &d__[1], &c__1, &q[1], &c__1); - i__1 = *n - 1; - scopy_(&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__) { - slartg_(&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 SLASDQ to compute the singular values. */ - - if (icompq == 0) { - slasdq_("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) { - slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu); - slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt); - slasdq_("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; - slaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n); - slaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n); - slasdq_("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) { - slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu); - slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt); - } - -/* Scale. */ - - orgnrm = slanst_("M", n, &d__[1], &e[1]); - if (orgnrm == 0.f) { - return 0; - } - slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr); - slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, & - ierr); - - eps = slamch_("Epsilon"); - - mlvl = (integer) (log((real) (*n) / (real) (smlsiz + 1)) / log(2.f)) + 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 ((r__1 = d__[i__], dabs(r__1)) < eps) { - d__[i__] = r_sign(&eps, &d__[i__]); - } -/* L20: */ - } - - start = 1; - sqre = 0; - - i__1 = nm1; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((r__1 = e[i__], dabs(r__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 ((r__1 = e[i__], dabs(r__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] = r_sign(&c_b15, &d__[*n]); - vt[*n + *n * vt_dim1] = 1.f; - } else if (icompq == 1) { - q[*n + (qstart - 1) * *n] = r_sign(&c_b15, &d__[*n]); - q[*n + (smlsiz + qstart - 1) * *n] = 1.f; - } - d__[*n] = (r__1 = d__[*n], dabs(r__1)); - } - if (icompq == 2) { - slasd0_(&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 { - slasda_(&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 */ - - slascl_("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) { - sswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], & - c__1); - sswap_(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) { - slasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu); - } - - return 0; - -/* End of SBDSDC */ - -} /* sbdsdc_ */ diff --git a/3rdparty/lapack/sbdsqr.c b/3rdparty/lapack/sbdsqr.c deleted file mode 100644 index fa3f04a..0000000 --- a/3rdparty/lapack/sbdsqr.c +++ /dev/null @@ -1,918 +0,0 @@ -/* sbdsqr.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 real c_b49 = 1.f; -static real c_b72 = -1.f; - -/* Subroutine */ int sbdsqr_(char *uplo, integer *n, integer *ncvt, integer * - nru, integer *ncc, real *d__, real *e, real *vt, integer *ldvt, real * - u, integer *ldu, real *c__, integer *ldc, real *work, integer *info) -{ - /* System generated locals */ - integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2; - real r__1, r__2, r__3, r__4; - doublereal d__1; - - /* Builtin functions */ - double pow_dd(doublereal *, doublereal *), sqrt(doublereal), r_sign(real * - , real *); - - /* Local variables */ - real f, g, h__; - integer i__, j, m; - real r__, cs; - integer ll; - real sn, mu; - integer nm1, nm12, nm13, lll; - real eps, sll, tol, abse; - integer idir; - real abss; - integer oldm; - real cosl; - integer isub, iter; - real unfl, sinl, cosr, smin, smax, sinr; - extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, - integer *, real *, real *), slas2_(real *, real *, real *, real *, - real *); - extern logical lsame_(char *, char *); - real oldcs; - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - integer oldll; - real shift, sigmn, oldsn; - integer maxit; - real sminl; - extern /* Subroutine */ int slasr_(char *, char *, char *, integer *, - integer *, real *, real *, real *, integer *); - real sigmx; - logical lower; - extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, - integer *), slasq1_(integer *, real *, real *, real *, integer *), - slasv2_(real *, real *, real *, real *, real *, real *, real *, - real *, real *); - extern doublereal slamch_(char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - real sminoa; - extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real * -); - real thresh; - logical rotate; - real tolmul; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* January 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SBDSQR 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 SGEBRD, 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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 REAL, 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_("SBDSQR", &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) { - slasq1_(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 = slamch_("Epsilon"); - unfl = slamch_("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__) { - slartg_(&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) { - slasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset], - ldu); - } - if (*ncc > 0) { - slasr_("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__1 = (doublereal) eps; - r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b15); - r__1 = 10.f, r__2 = dmin(r__3,r__4); - tolmul = dmax(r__1,r__2); - tol = tolmul * eps; - -/* Compute approximate maximum, minimum singular values */ - - smax = 0.f; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - r__2 = smax, r__3 = (r__1 = d__[i__], dabs(r__1)); - smax = dmax(r__2,r__3); -/* L20: */ - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - r__2 = smax, r__3 = (r__1 = e[i__], dabs(r__1)); - smax = dmax(r__2,r__3); -/* L30: */ - } - sminl = 0.f; - if (tol >= 0.f) { - -/* Relative accuracy desired */ - - sminoa = dabs(d__[1]); - if (sminoa == 0.f) { - goto L50; - } - mu = sminoa; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - mu = (r__2 = d__[i__], dabs(r__2)) * (mu / (mu + (r__1 = e[i__ - - 1], dabs(r__1)))); - sminoa = dmin(sminoa,mu); - if (sminoa == 0.f) { - goto L50; - } -/* L40: */ - } -L50: - sminoa /= sqrt((real) (*n)); -/* Computing MAX */ - r__1 = tol * sminoa, r__2 = *n * 6 * *n * unfl; - thresh = dmax(r__1,r__2); - } else { - -/* Absolute accuracy desired */ - -/* Computing MAX */ - r__1 = dabs(tol) * smax, r__2 = *n * 6 * *n * unfl; - thresh = dmax(r__1,r__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.f && (r__1 = d__[m], dabs(r__1)) <= thresh) { - d__[m] = 0.f; - } - smax = (r__1 = d__[m], dabs(r__1)); - smin = smax; - i__1 = m - 1; - for (lll = 1; lll <= i__1; ++lll) { - ll = m - lll; - abss = (r__1 = d__[ll], dabs(r__1)); - abse = (r__1 = e[ll], dabs(r__1)); - if (tol < 0.f && abss <= thresh) { - d__[ll] = 0.f; - } - if (abse <= thresh) { - goto L80; - } - smin = dmin(smin,abss); -/* Computing MAX */ - r__1 = max(smax,abss); - smax = dmax(r__1,abse); -/* L70: */ - } - ll = 0; - goto L90; -L80: - e[ll] = 0.f; - -/* 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 */ - - slasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, - &sinl, &cosl); - d__[m - 1] = sigmx; - e[m - 1] = 0.f; - d__[m] = sigmn; - -/* Compute singular vectors, if desired */ - - if (*ncvt > 0) { - srot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, & - cosr, &sinr); - } - if (*nru > 0) { - srot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], & - c__1, &cosl, &sinl); - } - if (*ncc > 0) { - srot_(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 ((r__1 = d__[ll], dabs(r__1)) >= (r__2 = d__[m], dabs(r__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 ((r__2 = e[m - 1], dabs(r__2)) <= dabs(tol) * (r__1 = d__[m], dabs( - r__1)) || tol < 0.f && (r__3 = e[m - 1], dabs(r__3)) <= - thresh) { - e[m - 1] = 0.f; - goto L60; - } - - if (tol >= 0.f) { - -/* If relative accuracy desired, */ -/* apply convergence criterion forward */ - - mu = (r__1 = d__[ll], dabs(r__1)); - sminl = mu; - i__1 = m - 1; - for (lll = ll; lll <= i__1; ++lll) { - if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) { - e[lll] = 0.f; - goto L60; - } - mu = (r__2 = d__[lll + 1], dabs(r__2)) * (mu / (mu + (r__1 = - e[lll], dabs(r__1)))); - sminl = dmin(sminl,mu); -/* L100: */ - } - } - - } else { - -/* Run convergence test in backward direction */ -/* First apply standard test to top of matrix */ - - if ((r__2 = e[ll], dabs(r__2)) <= dabs(tol) * (r__1 = d__[ll], dabs( - r__1)) || tol < 0.f && (r__3 = e[ll], dabs(r__3)) <= thresh) { - e[ll] = 0.f; - goto L60; - } - - if (tol >= 0.f) { - -/* If relative accuracy desired, */ -/* apply convergence criterion backward */ - - mu = (r__1 = d__[m], dabs(r__1)); - sminl = mu; - i__1 = ll; - for (lll = m - 1; lll >= i__1; --lll) { - if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) { - e[lll] = 0.f; - goto L60; - } - mu = (r__2 = d__[lll], dabs(r__2)) * (mu / (mu + (r__1 = e[ - lll], dabs(r__1)))); - sminl = dmin(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 */ - r__1 = eps, r__2 = tol * .01f; - if (tol >= 0.f && *n * tol * (sminl / smax) <= dmax(r__1,r__2)) { - -/* Use a zero shift to avoid loss of relative accuracy */ - - shift = 0.f; - } else { - -/* Compute the shift from 2-by-2 block at end of matrix */ - - if (idir == 1) { - sll = (r__1 = d__[ll], dabs(r__1)); - slas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); - } else { - sll = (r__1 = d__[m], dabs(r__1)); - slas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); - } - -/* Test if shift negligible, and if so set to zero */ - - if (sll > 0.f) { -/* Computing 2nd power */ - r__1 = shift / sll; - if (r__1 * r__1 < eps) { - shift = 0.f; - } - } - } - -/* Increment iteration count */ - - iter = iter + m - ll; - -/* If SHIFT = 0, do simplified QR iteration */ - - if (shift == 0.f) { - if (idir == 1) { - -/* Chase bulge from top to bottom */ -/* Save cosines and sines for later singular vector updates */ - - cs = 1.f; - oldcs = 1.f; - i__1 = m - 1; - for (i__ = ll; i__ <= i__1; ++i__) { - r__1 = d__[i__] * cs; - slartg_(&r__1, &e[i__], &cs, &sn, &r__); - if (i__ > ll) { - e[i__ - 1] = oldsn * r__; - } - r__1 = oldcs * r__; - r__2 = d__[i__ + 1] * sn; - slartg_(&r__1, &r__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; - slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[ - ll + vt_dim1], ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - slasr_("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; - slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 - + 1], &c__[ll + c_dim1], ldc); - } - -/* Test convergence */ - - if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) { - e[m - 1] = 0.f; - } - - } else { - -/* Chase bulge from bottom to top */ -/* Save cosines and sines for later singular vector updates */ - - cs = 1.f; - oldcs = 1.f; - i__1 = ll + 1; - for (i__ = m; i__ >= i__1; --i__) { - r__1 = d__[i__] * cs; - slartg_(&r__1, &e[i__ - 1], &cs, &sn, &r__); - if (i__ < m) { - e[i__] = oldsn * r__; - } - r__1 = oldcs * r__; - r__2 = d__[i__ - 1] * sn; - slartg_(&r__1, &r__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; - slasr_("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; - slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll * - u_dim1 + 1], ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[ - ll + c_dim1], ldc); - } - -/* Test convergence */ - - if ((r__1 = e[ll], dabs(r__1)) <= thresh) { - e[ll] = 0.f; - } - } - } else { - -/* Use nonzero shift */ - - if (idir == 1) { - -/* Chase bulge from top to bottom */ -/* Save cosines and sines for later singular vector updates */ - - f = ((r__1 = d__[ll], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[ - ll]) + shift / d__[ll]); - g = e[ll]; - i__1 = m - 1; - for (i__ = ll; i__ <= i__1; ++i__) { - slartg_(&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]; - slartg_(&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; - slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[ - ll + vt_dim1], ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - slasr_("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; - slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 - + 1], &c__[ll + c_dim1], ldc); - } - -/* Test convergence */ - - if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) { - e[m - 1] = 0.f; - } - - } else { - -/* Chase bulge from bottom to top */ -/* Save cosines and sines for later singular vector updates */ - - f = ((r__1 = d__[m], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[ - m]) + shift / d__[m]); - g = e[m - 1]; - i__1 = ll + 1; - for (i__ = m; i__ >= i__1; --i__) { - slartg_(&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]; - slartg_(&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 ((r__1 = e[ll], dabs(r__1)) <= thresh) { - e[ll] = 0.f; - } - -/* Update singular vectors if desired */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - slasr_("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; - slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll * - u_dim1 + 1], ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - slasr_("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.f) { - d__[i__] = -d__[i__]; - -/* Change sign of singular vectors, if desired */ - - if (*ncvt > 0) { - sscal_(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) { - sswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + - vt_dim1], ldvt); - } - if (*nru > 0) { - sswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * - u_dim1 + 1], &c__1); - } - if (*ncc > 0) { - sswap_(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.f) { - ++(*info); - } -/* L210: */ - } -L220: - return 0; - -/* End of SBDSQR */ - -} /* sbdsqr_ */ diff --git a/3rdparty/lapack/scopy.c b/3rdparty/lapack/scopy.c deleted file mode 100644 index 92cee80..0000000 --- a/3rdparty/lapack/scopy.c +++ /dev/null @@ -1,107 +0,0 @@ -/* scopy.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 scopy_(integer *n, real *sx, integer *incx, real *sy, - 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 1. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --sy; - --sx; - - /* 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__) { - sy[iy] = sx[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__) { - sy[i__] = sx[i__]; -/* L30: */ - } - if (*n < 7) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 7) { - sy[i__] = sx[i__]; - sy[i__ + 1] = sx[i__ + 1]; - sy[i__ + 2] = sx[i__ + 2]; - sy[i__ + 3] = sx[i__ + 3]; - sy[i__ + 4] = sx[i__ + 4]; - sy[i__ + 5] = sx[i__ + 5]; - sy[i__ + 6] = sx[i__ + 6]; -/* L50: */ - } - return 0; -} /* scopy_ */ diff --git a/3rdparty/lapack/sdot.c b/3rdparty/lapack/sdot.c deleted file mode 100644 index 5caed92..0000000 --- a/3rdparty/lapack/sdot.c +++ /dev/null @@ -1,109 +0,0 @@ -/* sdot.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 sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy) -{ - /* System generated locals */ - integer i__1; - real ret_val; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - real stemp; - -/* .. 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 */ - --sy; - --sx; - - /* Function Body */ - stemp = 0.f; - ret_val = 0.f; - 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__) { - stemp += sx[ix] * sy[iy]; - ix += *incx; - iy += *incy; -/* L10: */ - } - ret_val = stemp; - 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__) { - stemp += sx[i__] * sy[i__]; -/* L30: */ - } - if (*n < 5) { - goto L60; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 5) { - stemp = stemp + sx[i__] * sy[i__] + sx[i__ + 1] * sy[i__ + 1] + sx[ - i__ + 2] * sy[i__ + 2] + sx[i__ + 3] * sy[i__ + 3] + sx[i__ + - 4] * sy[i__ + 4]; -/* L50: */ - } -L60: - ret_val = stemp; - return ret_val; -} /* sdot_ */ diff --git a/3rdparty/lapack/sgebd2.c b/3rdparty/lapack/sgebd2.c deleted file mode 100644 index a7755ae..0000000 --- a/3rdparty/lapack/sgebd2.c +++ /dev/null @@ -1,303 +0,0 @@ -/* sgebd2.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 sgebd2_(integer *m, integer *n, real *a, integer *lda, - real *d__, real *e, real *tauq, real *taup, real *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, - integer *, real *, real *, integer *, real *), xerbla_( - char *, integer *), slarfg_(integer *, real *, real *, - integer *, real *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGEBD2 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) REAL 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) REAL array, dimension (min(M,N)) */ -/* The diagonal elements of the bidiagonal matrix B: */ -/* D(i) = A(i,i). */ - -/* E (output) REAL 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) REAL array dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Q. See Further Details. */ - -/* TAUP (output) REAL array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix P. See Further Details. */ - -/* WORK (workspace) REAL 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_("SGEBD2", &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; - slarfg_(&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.f; - -/* 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__; - slarf_("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; - slarfg_(&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.f; - -/* Apply G(i) to A(i+1:m,i+1:n) from the right */ - - i__2 = *m - i__; - i__3 = *n - i__; - slarf_("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.f; - } -/* 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; - slarfg_(&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.f; - -/* 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; - slarf_("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; - slarfg_(&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.f; - -/* Apply H(i) to A(i+1:m,i+1:n) from the left */ - - i__2 = *m - i__; - i__3 = *n - i__; - slarf_("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.f; - } -/* L20: */ - } - } - return 0; - -/* End of SGEBD2 */ - -} /* sgebd2_ */ diff --git a/3rdparty/lapack/sgebrd.c b/3rdparty/lapack/sgebrd.c deleted file mode 100644 index 2f2cd68..0000000 --- a/3rdparty/lapack/sgebrd.c +++ /dev/null @@ -1,336 +0,0 @@ -/* sgebrd.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 real c_b21 = -1.f; -static real c_b22 = 1.f; - -/* Subroutine */ int sgebrd_(integer *m, integer *n, real *a, integer *lda, - real *d__, real *e, real *tauq, real *taup, real *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; - real ws; - integer nbmin, iinfo; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - integer minmn; - extern /* Subroutine */ int sgebd2_(integer *, integer *, real *, integer - *, real *, real *, real *, real *, real *, integer *), slabrd_( - integer *, integer *, integer *, real *, integer *, real *, real * -, real *, real *, real *, integer *, real *, 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 */ -/* ======= */ - -/* SGEBRD 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) REAL 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) REAL array, dimension (min(M,N)) */ -/* The diagonal elements of the bidiagonal matrix B: */ -/* D(i) = A(i,i). */ - -/* E (output) REAL 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) REAL array dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Q. See Further Details. */ - -/* TAUP (output) REAL array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix P. See Further Details. */ - -/* WORK (workspace/output) REAL 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, "SGEBRD", " ", m, n, &c_n1, &c_n1); - nb = max(i__1,i__2); - lwkopt = (*m + *n) * nb; - work[1] = (real) 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_("SGEBRD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - minmn = min(*m,*n); - if (minmn == 0) { - work[1] = 1.f; - return 0; - } - - ws = (real) 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, "SGEBRD", " ", 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 = (real) ((*m + *n) * nb); - if ((real) (*lwork) < ws) { - -/* Not enough work space for the optimal NB, consider using */ -/* a smaller block size. */ - - nbmin = ilaenv_(&c__2, "SGEBRD", " ", 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; - slabrd_(&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; - sgemm_("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; - sgemm_("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; - sgebd2_(&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 SGEBRD */ - -} /* sgebrd_ */ diff --git a/3rdparty/lapack/sgelq2.c b/3rdparty/lapack/sgelq2.c deleted file mode 100644 index 6f17b9f..0000000 --- a/3rdparty/lapack/sgelq2.c +++ /dev/null @@ -1,157 +0,0 @@ -/* sgelq2.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 sgelq2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, k; - real aii; - extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, - integer *, real *, real *, integer *, real *), xerbla_( - char *, integer *), slarfp_(integer *, real *, real *, - integer *, real *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGELQ2 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) REAL 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) REAL array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* WORK (workspace) REAL 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_("SGELQ2", &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; - slarfp_(&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.f; - i__2 = *m - i__; - i__3 = *n - i__ + 1; - slarf_("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 SGELQ2 */ - -} /* sgelq2_ */ diff --git a/3rdparty/lapack/sgelqf.c b/3rdparty/lapack/sgelqf.c deleted file mode 100644 index c777eba..0000000 --- a/3rdparty/lapack/sgelqf.c +++ /dev/null @@ -1,251 +0,0 @@ -/* sgelqf.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 sgelqf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *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 sgelq2_(integer *, integer *, real *, integer - *, real *, real *, integer *), slarfb_(char *, char *, char *, - char *, integer *, integer *, integer *, real *, integer *, real * -, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *, - real *, integer *, real *, real *, 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 */ -/* ======= */ - -/* SGELQF 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) REAL 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) REAL array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* WORK (workspace/output) REAL 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, "SGELQF", " ", m, n, &c_n1, &c_n1); - lwkopt = *m * nb; - work[1] = (real) 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_("SGELQF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - k = min(*m,*n); - if (k == 0) { - work[1] = 1.f; - 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, "SGELQF", " ", 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, "SGELQF", " ", 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; - sgelq2_(&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; - slarft_("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; - slarfb_("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; - sgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] -, &iinfo); - } - - work[1] = (real) iws; - return 0; - -/* End of SGELQF */ - -} /* sgelqf_ */ diff --git a/3rdparty/lapack/sgels.c b/3rdparty/lapack/sgels.c deleted file mode 100644 index f5017bf..0000000 --- a/3rdparty/lapack/sgels.c +++ /dev/null @@ -1,513 +0,0 @@ -/* sgels.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 real c_b33 = 0.f; -static integer c__0 = 0; - -/* Subroutine */ int sgels_(char *trans, integer *m, integer *n, integer * - nrhs, real *a, integer *lda, real *b, integer *ldb, real *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; - real anrm, bnrm; - integer brow; - logical tpsd; - integer iascl, ibscl; - extern logical lsame_(char *, char *); - integer wsize; - real rwork[1]; - extern /* Subroutine */ int slabad_(real *, real *); - extern doublereal slamch_(char *), slange_(char *, integer *, - integer *, real *, integer *, real *); - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - integer scllen; - real bignum; - extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer - *, real *, real *, integer *, integer *), slascl_(char *, integer - *, integer *, real *, real *, integer *, integer *, real *, - integer *, integer *), sgeqrf_(integer *, integer *, real - *, integer *, real *, real *, integer *, integer *), slaset_(char - *, integer *, integer *, real *, real *, real *, integer *); - real smlnum; - extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *, integer *); - logical lquery; - extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *, integer *), strtrs_(char *, char *, - char *, integer *, integer *, real *, integer *, real *, 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 */ -/* ======= */ - -/* SGELS 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) REAL 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 SGEQRF; */ -/* if M < N, A is overwritten by details of its LQ */ -/* factorization as returned by SGELQF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) REAL 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) REAL 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, "SGEQRF", " ", m, n, &c_n1, &c_n1); - if (tpsd) { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "SORMQR", "LN", m, nrhs, n, & - c_n1); - nb = max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "SORMQR", "LT", m, nrhs, n, & - c_n1); - nb = max(i__1,i__2); - } - } else { - nb = ilaenv_(&c__1, "SGELQF", " ", m, n, &c_n1, &c_n1); - if (tpsd) { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "SORMLQ", "LT", n, nrhs, m, & - c_n1); - nb = max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "SORMLQ", "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] = (real) wsize; - - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SGELS ", &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); - slaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb); - return 0; - } - -/* Get machine parameters */ - - smlnum = slamch_("S") / slamch_("P"); - bignum = 1.f / smlnum; - slabad_(&smlnum, &bignum); - -/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */ - - anrm = slange_("M", m, n, &a[a_offset], lda, rwork); - iascl = 0; - if (anrm > 0.f && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - slascl_("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 */ - - slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.f) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = max(*m,*n); - slaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb); - goto L50; - } - - brow = *m; - if (tpsd) { - brow = *n; - } - bnrm = slange_("M", &brow, nrhs, &b[b_offset], ldb, rwork); - ibscl = 0; - if (bnrm > 0.f && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - slascl_("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 */ - - slascl_("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; - sgeqrf_(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; - sormqr_("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) */ - - strtrs_("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) */ - - strtrs_("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.f; -/* L10: */ - } -/* L20: */ - } - -/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */ - - i__1 = *lwork - mn; - sormqr_("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; - sgelqf_(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) */ - - strtrs_("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.f; -/* L30: */ - } -/* L40: */ - } - -/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */ - - i__1 = *lwork - mn; - sormlq_("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; - sormlq_("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) */ - - strtrs_("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) { - slascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset] -, ldb, info); - } else if (iascl == 2) { - slascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset] -, ldb, info); - } - if (ibscl == 1) { - slascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset] -, ldb, info); - } else if (ibscl == 2) { - slascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset] -, ldb, info); - } - -L50: - work[1] = (real) wsize; - - return 0; - -/* End of SGELS */ - -} /* sgels_ */ diff --git a/3rdparty/lapack/sgelsd.c b/3rdparty/lapack/sgelsd.c deleted file mode 100644 index 1e3d174..0000000 --- a/3rdparty/lapack/sgelsd.c +++ /dev/null @@ -1,699 +0,0 @@ -/* sgelsd.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__6 = 6; -static integer c_n1 = -1; -static integer c__1 = 1; -static real c_b81 = 0.f; - -/* Subroutine */ int sgelsd_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, real *s, real *rcond, integer * - rank, real *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; - real eps, anrm, bnrm; - integer itau, nlvl, iascl, ibscl; - real sfmin; - integer minmn, maxmn, itaup, itauq, mnthr, nwork; - extern /* Subroutine */ int slabad_(real *, real *), sgebrd_(integer *, - integer *, real *, integer *, real *, real *, real *, real *, - real *, integer *, integer *); - extern doublereal slamch_(char *), slange_(char *, integer *, - integer *, real *, integer *, real *); - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - real bignum; - extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer - *, real *, real *, integer *, integer *), slalsd_(char *, integer - *, integer *, integer *, real *, real *, real *, integer *, real * -, integer *, real *, integer *, integer *), slascl_(char * -, integer *, integer *, real *, real *, integer *, integer *, - real *, integer *, integer *); - integer wlalsd; - extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer - *, real *, real *, integer *, integer *), slacpy_(char *, integer - *, integer *, real *, integer *, real *, integer *), - slaset_(char *, integer *, integer *, real *, real *, real *, - integer *); - integer ldwork; - extern /* Subroutine */ int sormbr_(char *, char *, char *, integer *, - integer *, integer *, real *, integer *, real *, real *, integer * -, real *, integer *, integer *); - integer liwork, minwrk, maxwrk; - real smlnum; - extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *, integer *); - logical lquery; - integer smlsiz; - extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - 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 */ -/* ======= */ - -/* SGELSD 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) REAL 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) REAL 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) REAL 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) REAL */ -/* 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) REAL 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 array WORK and the */ -/* minimum size of the array IWORK, and returns these values as */ -/* the first entries of the WORK and IWORK arrays, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN), */ -/* where MINMN = MIN( M,N ). */ -/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */ - -/* 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); - 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; - } - -/* 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.) */ - - if (*info == 0) { - minwrk = 1; - maxwrk = 1; - liwork = 1; - if (minmn > 0) { - smlsiz = ilaenv_(&c__9, "SGELSD", " ", &c__0, &c__0, &c__0, &c__0); - mnthr = ilaenv_(&c__6, "SGELSD", " ", m, n, nrhs, &c_n1); -/* Computing MAX */ - i__1 = (integer) (log((real) minmn / (real) (smlsiz + 1)) / log( - 2.f)) + 1; - nlvl = max(i__1,0); - liwork = minmn * 3 * nlvl + minmn * 11; - 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, "SGEQRF", - " ", m, n, &c_n1, &c_n1); - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "SORMQR", - "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, - "SGEBRD", " ", &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, "SORMBR" -, "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, - "SORMBR", "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, "SGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * - ilaenv_(&c__1, "SGEBRD", " ", 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, "SORMBR", "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, "SORMBR", "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, "SORMLQ" -, "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, "SGEBRD", - " ", m, n, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, - "SORMBR", "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, "SORM" - "BR", "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] = (real) maxwrk; - iwork[1] = liwork; - - if (*lwork < minwrk && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SGELSD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - *rank = 0; - return 0; - } - -/* Get machine parameters. */ - - eps = slamch_("P"); - sfmin = slamch_("S"); - smlnum = sfmin / eps; - bignum = 1.f / smlnum; - slabad_(&smlnum, &bignum); - -/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */ - - anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]); - iascl = 0; - if (anrm > 0.f && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM. */ - - slascl_("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. */ - - slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.f) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = max(*m,*n); - slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[b_offset], ldb); - slaset_("F", &minmn, &c__1, &c_b81, &c_b81, &s[1], &c__1); - *rank = 0; - goto L10; - } - -/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */ - - bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); - ibscl = 0; - if (bnrm > 0.f && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM. */ - - slascl_("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. */ - - slascl_("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; - slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &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; - sgeqrf_(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; - sormqr_("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; - slaset_("L", &i__1, &i__2, &c_b81, &c_b81, &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; - sgebrd_(&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; - sormbr_("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. */ - - slalsd_("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; - sormbr_("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; - sgelqf_(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. */ - - slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); - i__1 = *m - 1; - i__2 = *m - 1; - slaset_("U", &i__1, &i__2, &c_b81, &c_b81, &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; - sgebrd_(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; - sormbr_("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. */ - - slalsd_("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; - sormbr_("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; - slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &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; - sormlq_("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; - sgebrd_(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; - sormbr_("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. */ - - slalsd_("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; - sormbr_("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) { - slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, - info); - slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, info); - } else if (iascl == 2) { - slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, - info); - slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, info); - } - if (ibscl == 1) { - slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } else if (ibscl == 2) { - slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } - -L10: - work[1] = (real) maxwrk; - iwork[1] = liwork; - return 0; - -/* End of SGELSD */ - -} /* sgelsd_ */ diff --git a/3rdparty/lapack/sgemm.c b/3rdparty/lapack/sgemm.c deleted file mode 100644 index 8e8a556..0000000 --- a/3rdparty/lapack/sgemm.c +++ /dev/null @@ -1,388 +0,0 @@ -/* sgemm.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 sgemm_(char *transa, char *transb, integer *m, integer * - n, integer *k, real *alpha, real *a, integer *lda, real *b, integer * - ldb, real *beta, real *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; - real temp; - integer ncola; - extern logical lsame_(char *, char *); - integer nrowa, nrowb; - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGEMM 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 - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - REAL 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 - REAL 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 - REAL . */ -/* 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 - REAL 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_("SGEMM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { - return 0; - } - -/* And if alpha.eq.zero. */ - - if (*alpha == 0.f) { - if (*beta == 0.f) { - 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.f; -/* 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.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L50: */ - } - } else if (*beta != 1.f) { - 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.f) { - 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.f; - 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.f) { - 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.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L130: */ - } - } else if (*beta != 1.f) { - 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.f) { - 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.f; - 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.f) { - 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 SGEMM . */ - -} /* sgemm_ */ diff --git a/3rdparty/lapack/sgemv_custom.c b/3rdparty/lapack/sgemv_custom.c deleted file mode 100644 index eff4418..0000000 --- a/3rdparty/lapack/sgemv_custom.c +++ /dev/null @@ -1,232 +0,0 @@ -#include "clapack.h" -#include - -/* Subroutine */ int sgemv_(char *_trans, integer *_m, integer *_n, real *_alpha, - real *a, integer *_lda, real *x, integer *_incx, real *_beta, real *y, - integer *_incy) -{ - - /* .. Scalar Arguments .. */ - /* .. */ - /* .. Array Arguments .. */ - /* .. */ - - /* Purpose */ - /* ======= */ - - /* SGEMV 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 - REAL . */ - /* On entry, ALPHA specifies the scalar alpha. */ - /* Unchanged on exit. */ - - /* A - REAL 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 - REAL 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 - REAL . */ - /* 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 - REAL 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. */ - - /* Test the input parameters. */ - - /* Function Body */ - 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; - real 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.f ) - { - if( incy == 1 ) - { - if( beta == 0.f ) - for( i = 0; i < leny; i++ ) - y[i] = 0.f; - else - for( i = 0; i < leny; i++ ) - y[i] *= beta; - } - else - { - if( beta == 0.f ) - for( i = 0; i < leny; i++ ) - y[i*incy] = 0.f; - else - for( i = 0; i < leny; i++ ) - y[i*incy] *= beta; - } - } - - if( alpha == 0.f ) - ; - else if( trans == 'N' ) - { - if( incy == 1 ) - { - for( i = 0; i < n; i++, a += lda ) - { - real s = x[i*incx]; - if( s == 0.f ) - continue; - s *= alpha; - - for( j = 0; j <= m - 4; j += 4 ) - { - real t0 = y[j] + s*a[j]; - real 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 ) - { - real 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 ) - { - real 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 ) - { - real s = 0; - for( j = 0; j < m; j++ ) - s += x[j*incx]*a[j]; - y[i*incy] += alpha*s; - } - } - } - - return 0; - - /* End of SGEMV . */ - -} /* sgemv_ */ diff --git a/3rdparty/lapack/sgeqr2.c b/3rdparty/lapack/sgeqr2.c deleted file mode 100644 index 001b8ef..0000000 --- a/3rdparty/lapack/sgeqr2.c +++ /dev/null @@ -1,161 +0,0 @@ -/* sgeqr2.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 sgeqr2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, k; - real aii; - extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, - integer *, real *, real *, integer *, real *), xerbla_( - char *, integer *), slarfp_(integer *, real *, real *, - integer *, real *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGEQR2 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) REAL 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) REAL array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* WORK (workspace) REAL 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_("SGEQR2", &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; - slarfp_(&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.f; - i__2 = *m - i__ + 1; - i__3 = *n - i__; - slarf_("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 SGEQR2 */ - -} /* sgeqr2_ */ diff --git a/3rdparty/lapack/sgeqrf.c b/3rdparty/lapack/sgeqrf.c deleted file mode 100644 index 6a1e557..0000000 --- a/3rdparty/lapack/sgeqrf.c +++ /dev/null @@ -1,252 +0,0 @@ -/* sgeqrf.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 sgeqrf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *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 sgeqr2_(integer *, integer *, real *, integer - *, real *, real *, integer *), slarfb_(char *, char *, char *, - char *, integer *, integer *, integer *, real *, integer *, real * -, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *, - real *, integer *, real *, real *, 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 */ -/* ======= */ - -/* SGEQRF 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) REAL 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) REAL array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* WORK (workspace/output) REAL 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, "SGEQRF", " ", m, n, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (real) 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_("SGEQRF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - k = min(*m,*n); - if (k == 0) { - work[1] = 1.f; - 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, "SGEQRF", " ", 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, "SGEQRF", " ", 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; - sgeqr2_(&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; - slarft_("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; - slarfb_("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; - sgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] -, &iinfo); - } - - work[1] = (real) iws; - return 0; - -/* End of SGEQRF */ - -} /* sgeqrf_ */ diff --git a/3rdparty/lapack/sger_custom.c b/3rdparty/lapack/sger_custom.c deleted file mode 100644 index b364872..0000000 --- a/3rdparty/lapack/sger_custom.c +++ /dev/null @@ -1,164 +0,0 @@ -#include "clapack.h" - -/* Subroutine */ int sger_(integer *_m, integer *_n, real *_alpha, - real *x, integer *_incx, real *y, integer *_incy, - real *a, integer *_lda) -{ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGER 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 - SINGLE PRECISION. */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* X - SINGLE 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 - SINGLE 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 - SINGLE 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; - real 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_("SGER ", &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 ) - { - real s = y[j*incy]; - if( s == 0 ) - continue; - s *= alpha; - - for( i = 0; i <= m - 2; i += 2 ) - { - real t0 = a[i] + x[i]*s; - real 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 ) - { - real 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 SGER . */ - -} /* sger_ */ diff --git a/3rdparty/lapack/sgesdd.c b/3rdparty/lapack/sgesdd.c deleted file mode 100644 index 47eea27..0000000 --- a/3rdparty/lapack/sgesdd.c +++ /dev/null @@ -1,1611 +0,0 @@ -/* sgesdd.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__0 = 0; -static real c_b227 = 0.f; -static real c_b248 = 1.f; - -/* Subroutine */ int sgesdd_(char *jobz, integer *m, integer *n, real *a, - integer *lda, real *s, real *u, integer *ldu, real *vt, integer *ldvt, - real *work, integer *lwork, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2, i__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, ie, il, ir, iu, blk; - real dum[1], eps; - integer ivt, iscl; - real anrm; - integer idum[1], ierr, itau; - extern logical lsame_(char *, char *); - integer chunk; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - integer minmn, wrkbl, itaup, itauq, mnthr; - logical wntqa; - integer nwork; - logical wntqn, wntqo, wntqs; - integer bdspac; - extern /* Subroutine */ int sbdsdc_(char *, char *, integer *, real *, - real *, real *, integer *, real *, integer *, real *, integer *, - real *, integer *, integer *), sgebrd_(integer *, - integer *, real *, integer *, real *, real *, real *, real *, - real *, integer *, integer *); - extern doublereal slamch_(char *), slange_(char *, integer *, - integer *, real *, integer *, real *); - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - real bignum; - extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer - *, real *, real *, integer *, integer *), slascl_(char *, integer - *, integer *, real *, real *, integer *, integer *, real *, - integer *, integer *), sgeqrf_(integer *, integer *, real - *, integer *, real *, real *, integer *, integer *), slacpy_(char - *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, - real *, integer *), sorgbr_(char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, integer * -); - integer ldwrkl; - extern /* Subroutine */ int sormbr_(char *, char *, char *, integer *, - integer *, integer *, real *, integer *, real *, real *, integer * -, real *, integer *, integer *); - integer ldwrkr, minwrk, ldwrku, maxwrk; - extern /* Subroutine */ int sorglq_(integer *, integer *, integer *, real - *, integer *, real *, real *, integer *, integer *); - integer ldwkvt; - real smlnum; - logical wntqas; - extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real - *, integer *, real *, real *, integer *, integer *); - logical lquery; - - -/* -- LAPACK driver 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..-- */ -/* March 2009 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGESDD computes the singular value decomposition (SVD) of a real */ -/* M-by-N matrix A, optionally computing the left and right singular */ -/* vectors. If singular vectors are desired, it uses a */ -/* divide-and-conquer algorithm. */ - -/* The SVD is written */ - -/* A = U * SIGMA * transpose(V) */ - -/* where SIGMA is an M-by-N matrix which is zero except for its */ -/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */ -/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */ -/* are the singular values of A; they are real and non-negative, and */ -/* are returned in descending order. The first min(m,n) columns of */ -/* U and V are the left and right singular vectors of A. */ - -/* Note that the routine returns VT = V**T, not V. */ - -/* 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 */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* Specifies options for computing all or part of the matrix U: */ -/* = 'A': all M columns of U and all N rows of V**T are */ -/* returned in the arrays U and VT; */ -/* = 'S': the first min(M,N) columns of U and the first */ -/* min(M,N) rows of V**T are returned in the arrays U */ -/* and VT; */ -/* = 'O': If M >= N, the first N columns of U are overwritten */ -/* on the array A and all rows of V**T are returned in */ -/* the array VT; */ -/* otherwise, all columns of U are returned in the */ -/* array U and the first M rows of V**T are overwritten */ -/* in the array A; */ -/* = 'N': no columns of U or rows of V**T are computed. */ - -/* M (input) INTEGER */ -/* The number of rows of the input matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the input matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, */ -/* if JOBZ = 'O', A is overwritten with the first N columns */ -/* of U (the left singular vectors, stored */ -/* columnwise) if M >= N; */ -/* A is overwritten with the first M rows */ -/* of V**T (the right singular vectors, stored */ -/* rowwise) otherwise. */ -/* if JOBZ .ne. 'O', the contents of A are destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* S (output) REAL array, dimension (min(M,N)) */ -/* The singular values of A, sorted so that S(i) >= S(i+1). */ - -/* U (output) REAL array, dimension (LDU,UCOL) */ -/* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; */ -/* UCOL = min(M,N) if JOBZ = 'S'. */ -/* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M */ -/* orthogonal matrix U; */ -/* if JOBZ = 'S', U contains the first min(M,N) columns of U */ -/* (the left singular vectors, stored columnwise); */ -/* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= 1; if */ -/* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. */ - -/* VT (output) REAL array, dimension (LDVT,N) */ -/* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the */ -/* N-by-N orthogonal matrix V**T; */ -/* if JOBZ = 'S', VT contains the first min(M,N) rows of */ -/* V**T (the right singular vectors, stored rowwise); */ -/* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. LDVT >= 1; if */ -/* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; */ -/* if JOBZ = 'S', LDVT >= min(M,N). */ - -/* WORK (workspace/output) REAL 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 >= 1. */ -/* If JOBZ = 'N', */ -/* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)). */ -/* If JOBZ = 'O', */ -/* LWORK >= 3*min(M,N) + */ -/* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). */ -/* If JOBZ = 'S' or 'A' */ -/* LWORK >= 3*min(M,N) + */ -/* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)). */ -/* For good performance, LWORK should generally be larger. */ -/* If LWORK = -1 but other input arguments are legal, WORK(1) */ -/* returns the optimal LWORK. */ - -/* IWORK (workspace) INTEGER array, dimension (8*min(M,N)) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: SBDSDC did not converge, updating process failed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. 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; - --s; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - minmn = min(*m,*n); - wntqa = lsame_(jobz, "A"); - wntqs = lsame_(jobz, "S"); - wntqas = wntqa || wntqs; - wntqo = lsame_(jobz, "O"); - wntqn = lsame_(jobz, "N"); - lquery = *lwork == -1; - - if (! (wntqa || wntqs || wntqo || wntqn)) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < * - m) { - *info = -8; - } else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn || - wntqo && *m >= *n && *ldvt < *n) { - *info = -10; - } - -/* 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.) */ - - if (*info == 0) { - minwrk = 1; - maxwrk = 1; - if (*m >= *n && minmn > 0) { - -/* Compute space needed for SBDSDC */ - - mnthr = (integer) (minmn * 11.f / 6.f); - if (wntqn) { - bdspac = *n * 7; - } else { - bdspac = *n * 3 * *n + (*n << 2); - } - if (*m >= mnthr) { - if (wntqn) { - -/* Path 1 (M much larger than N, JOBZ='N') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "SGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n; - maxwrk = max(i__1,i__2); - minwrk = bdspac + *n; - } else if (wntqo) { - -/* Path 2 (M much larger than N, JOBZ='O') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "SORGQR", - " ", m, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "SGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + (*n << 1) * *n; - minwrk = bdspac + (*n << 1) * *n + *n * 3; - } else if (wntqs) { - -/* Path 3 (M much larger than N, JOBZ='S') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "SORGQR", - " ", m, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "SGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *n * *n; - minwrk = bdspac + *n * *n + *n * 3; - } else if (wntqa) { - -/* Path 4 (M much larger than N, JOBZ='A') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *m * ilaenv_(&c__1, "SORGQR", - " ", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "SGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *n * *n; - minwrk = bdspac + *n * *n + *n * 3; - } - } else { - -/* Path 5 (M at least N, but not much larger) */ - - wrkbl = *n * 3 + (*m + *n) * ilaenv_(&c__1, "SGEBRD", " ", m, - n, &c_n1, &c_n1); - if (wntqn) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - maxwrk = max(i__1,i__2); - minwrk = *n * 3 + max(*m,bdspac); - } else if (wntqo) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "QLN", m, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *m * *n; -/* Computing MAX */ - i__1 = *m, i__2 = *n * *n + bdspac; - minwrk = *n * 3 + max(i__1,i__2); - } else if (wntqs) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "QLN", m, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - maxwrk = max(i__1,i__2); - minwrk = *n * 3 + max(*m,bdspac); - } else if (wntqa) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = bdspac + *n * 3; - maxwrk = max(i__1,i__2); - minwrk = *n * 3 + max(*m,bdspac); - } - } - } else if (minmn > 0) { - -/* Compute space needed for SBDSDC */ - - mnthr = (integer) (minmn * 11.f / 6.f); - if (wntqn) { - bdspac = *m * 7; - } else { - bdspac = *m * 3 * *m + (*m << 2); - } - if (*n >= mnthr) { - if (wntqn) { - -/* Path 1t (N much larger than M, JOBZ='N') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "SGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m; - maxwrk = max(i__1,i__2); - minwrk = bdspac + *m; - } else if (wntqo) { - -/* Path 2t (N much larger than M, JOBZ='O') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "SORGLQ", - " ", m, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "SGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + (*m << 1) * *m; - minwrk = bdspac + (*m << 1) * *m + *m * 3; - } else if (wntqs) { - -/* Path 3t (N much larger than M, JOBZ='S') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "SORGLQ", - " ", m, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "SGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *m * *m; - minwrk = bdspac + *m * *m + *m * 3; - } else if (wntqa) { - -/* Path 4t (N much larger than M, JOBZ='A') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *n * ilaenv_(&c__1, "SORGLQ", - " ", n, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "SGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *m * *m; - minwrk = bdspac + *m * *m + *m * 3; - } - } else { - -/* Path 5t (N greater than M, but not much larger) */ - - wrkbl = *m * 3 + (*m + *n) * ilaenv_(&c__1, "SGEBRD", " ", m, - n, &c_n1, &c_n1); - if (wntqn) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = max(i__1,i__2); - minwrk = *m * 3 + max(*n,bdspac); - } else if (wntqo) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "PRT", m, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = max(i__1,i__2); - maxwrk = wrkbl + *m * *n; -/* Computing MAX */ - i__1 = *n, i__2 = *m * *m + bdspac; - minwrk = *m * 3 + max(i__1,i__2); - } else if (wntqs) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "PRT", m, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = max(i__1,i__2); - minwrk = *m * 3 + max(*n,bdspac); - } else if (wntqa) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR" -, "PRT", n, n, m, &c_n1); - wrkbl = max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = max(i__1,i__2); - minwrk = *m * 3 + max(*n,bdspac); - } - } - } - maxwrk = max(maxwrk,minwrk); - work[1] = (real) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SGESDD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = slamch_("P"); - smlnum = sqrt(slamch_("S")) / eps; - bignum = 1.f / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = slange_("M", m, n, &a[a_offset], lda, dum); - iscl = 0; - if (anrm > 0.f && anrm < smlnum) { - iscl = 1; - slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & - ierr); - } else if (anrm > bignum) { - iscl = 1; - slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & - ierr); - } - - if (*m >= *n) { - -/* A has at least as many rows as columns. If A has sufficiently */ -/* more rows than columns, first reduce using the QR */ -/* decomposition (if sufficient workspace available) */ - - if (*m >= mnthr) { - - if (wntqn) { - -/* Path 1 (M much larger than N, JOBZ='N') */ -/* No singular vectors to be computed */ - - itau = 1; - nwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__1 = *lwork - nwork + 1; - sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Zero out below R */ - - i__1 = *n - 1; - i__2 = *n - 1; - slaset_("L", &i__1, &i__2, &c_b227, &c_b227, &a[a_dim1 + 2], - lda); - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in A */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__1 = *lwork - nwork + 1; - sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - nwork = ie + *n; - -/* Perform bidiagonal SVD, computing singular values only */ -/* (Workspace: need N+BDSPAC) */ - - sbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - - } else if (wntqo) { - -/* Path 2 (M much larger than N, JOBZ = 'O') */ -/* N left singular vectors to be overwritten on A and */ -/* N right singular vectors to be computed in VT */ - - ir = 1; - -/* WORK(IR) is LDWRKR by N */ - - if (*lwork >= *lda * *n + *n * *n + *n * 3 + bdspac) { - ldwrkr = *lda; - } else { - ldwrkr = (*lwork - *n * *n - *n * 3 - bdspac) / *n; - } - itau = ir + ldwrkr * *n; - nwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__1 = *lwork - nwork + 1; - sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Copy R to WORK(IR), zeroing out below it */ - - slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); - i__1 = *n - 1; - i__2 = *n - 1; - slaset_("L", &i__1, &i__2, &c_b227, &c_b227, &work[ir + 1], & - ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__1 = *lwork - nwork + 1; - sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], - &i__1, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in VT, copying result to WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__1 = *lwork - nwork + 1; - sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - -/* WORK(IU) is N by N */ - - iu = nwork; - nwork = iu + *n * *n; - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - sbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite WORK(IU) by left singular vectors of R */ -/* and VT by right singular vectors of R */ -/* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */ - - i__1 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[ - itauq], &work[iu], n, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - sormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IU), storing result in WORK(IR) and copying to A */ -/* (Workspace: need 2*N*N, prefer N*N+M*N) */ - - i__1 = *m; - i__2 = ldwrkr; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = *m - i__ + 1; - chunk = min(i__3,ldwrkr); - sgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + a_dim1], - lda, &work[iu], n, &c_b227, &work[ir], &ldwrkr); - slacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + - a_dim1], lda); -/* L10: */ - } - - } else if (wntqs) { - -/* Path 3 (M much larger than N, JOBZ='S') */ -/* N left singular vectors to be computed in U and */ -/* N right singular vectors to be computed in VT */ - - ir = 1; - -/* WORK(IR) is N by N */ - - ldwrkr = *n; - itau = ir + ldwrkr * *n; - nwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - -/* Copy R to WORK(IR), zeroing out below it */ - - slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); - i__2 = *n - 1; - i__1 = *n - 1; - slaset_("L", &i__2, &i__1, &c_b227, &c_b227, &work[ir + 1], & - ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], - &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - nwork + 1; - sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagoal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - sbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of R and VT */ -/* by right singular vectors of R */ -/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */ - - i__2 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - - i__2 = *lwork - nwork + 1; - sormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IR), storing result in U */ -/* (Workspace: need N*N) */ - - slacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr); - sgemm_("N", "N", m, n, n, &c_b248, &a[a_offset], lda, &work[ - ir], &ldwrkr, &c_b227, &u[u_offset], ldu); - - } else if (wntqa) { - -/* Path 4 (M much larger than N, JOBZ='A') */ -/* M left singular vectors to be computed in U and */ -/* N right singular vectors to be computed in VT */ - - iu = 1; - -/* WORK(IU) is N by N */ - - ldwrku = *n; - itau = iu + ldwrku * *n; - nwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu); - -/* Generate Q in U */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - i__2 = *lwork - nwork + 1; - sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork], - &i__2, &ierr); - -/* Produce R in A, zeroing out other entries */ - - i__2 = *n - 1; - i__1 = *n - 1; - slaset_("L", &i__2, &i__1, &c_b227, &c_b227, &a[a_dim1 + 2], - lda); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in A */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - nwork + 1; - sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - sbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite WORK(IU) by left singular vectors of R and VT */ -/* by right singular vectors of R */ -/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */ - - i__2 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", n, n, n, &a[a_offset], lda, &work[ - itauq], &work[iu], &ldwrku, &work[nwork], &i__2, & - ierr); - i__2 = *lwork - nwork + 1; - sormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply Q in U by left singular vectors of R in */ -/* WORK(IU), storing result in A */ -/* (Workspace: need N*N) */ - - sgemm_("N", "N", m, n, n, &c_b248, &u[u_offset], ldu, &work[ - iu], &ldwrku, &c_b227, &a[a_offset], lda); - -/* Copy left singular vectors of A from A to U */ - - slacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu); - - } - - } else { - -/* M .LT. MNTHR */ - -/* Path 5 (M at least N, but not much larger) */ -/* Reduce to bidiagonal form without QR decomposition */ - - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize A */ -/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */ - - i__2 = *lwork - nwork + 1; - sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__2, &ierr); - if (wntqn) { - -/* Perform bidiagonal SVD, only computing singular values */ -/* (Workspace: need N+BDSPAC) */ - - sbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - } else if (wntqo) { - iu = nwork; - if (*lwork >= *m * *n + *n * 3 + bdspac) { - -/* WORK( IU ) is M by N */ - - ldwrku = *m; - nwork = iu + ldwrku * *n; - slaset_("F", m, n, &c_b227, &c_b227, &work[iu], &ldwrku); - } else { - -/* WORK( IU ) is N by N */ - - ldwrku = *n; - nwork = iu + ldwrku * *n; - -/* WORK(IR) is LDWRKR by N */ - - ir = nwork; - ldwrkr = (*lwork - *n * *n - *n * 3) / *n; - } - nwork = iu + ldwrku * *n; - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - sbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], &ldwrku, & - vt[vt_offset], ldvt, dum, idum, &work[nwork], &iwork[ - 1], info); - -/* Overwrite VT by right singular vectors of A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - sormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - - if (*lwork >= *m * *n + *n * 3 + bdspac) { - -/* Overwrite WORK(IU) by left singular vectors of A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[ - itauq], &work[iu], &ldwrku, &work[nwork], &i__2, & - ierr); - -/* Copy left singular vectors of A from WORK(IU) to A */ - - slacpy_("F", m, n, &work[iu], &ldwrku, &a[a_offset], lda); - } else { - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - sorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], & - work[nwork], &i__2, &ierr); - -/* Multiply Q in A by left singular vectors of */ -/* bidiagonal matrix in WORK(IU), storing result in */ -/* WORK(IR) and copying to A */ -/* (Workspace: need 2*N*N, prefer N*N+M*N) */ - - i__2 = *m; - i__1 = ldwrkr; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { -/* Computing MIN */ - i__3 = *m - i__ + 1; - chunk = min(i__3,ldwrkr); - sgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + - a_dim1], lda, &work[iu], &ldwrku, &c_b227, & - work[ir], &ldwrkr); - slacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + - a_dim1], lda); -/* L20: */ - } - } - - } else if (wntqs) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - slaset_("F", m, n, &c_b227, &c_b227, &u[u_offset], ldu); - sbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 3*N, prefer 2*N+N*NB) */ - - i__1 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - sormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } else if (wntqa) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - slaset_("F", m, m, &c_b227, &c_b227, &u[u_offset], ldu); - sbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Set the right corner of U to identity matrix */ - - if (*m > *n) { - i__1 = *m - *n; - i__2 = *m - *n; - slaset_("F", &i__1, &i__2, &c_b227, &c_b248, &u[*n + 1 + ( - *n + 1) * u_dim1], ldu); - } - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) */ - - i__1 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - sormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } - - } - - } else { - -/* A has more columns than rows. If A has sufficiently more */ -/* columns than rows, first reduce using the LQ decomposition (if */ -/* sufficient workspace available) */ - - if (*n >= mnthr) { - - if (wntqn) { - -/* Path 1t (N much larger than M, JOBZ='N') */ -/* No singular vectors to be computed */ - - itau = 1; - nwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__1 = *lwork - nwork + 1; - sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Zero out above L */ - - i__1 = *m - 1; - i__2 = *m - 1; - slaset_("U", &i__1, &i__2, &c_b227, &c_b227, &a[(a_dim1 << 1) - + 1], lda); - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in A */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__1 = *lwork - nwork + 1; - sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - nwork = ie + *m; - -/* Perform bidiagonal SVD, computing singular values only */ -/* (Workspace: need M+BDSPAC) */ - - sbdsdc_("U", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - - } else if (wntqo) { - -/* Path 2t (N much larger than M, JOBZ='O') */ -/* M right singular vectors to be overwritten on A and */ -/* M left singular vectors to be computed in U */ - - ivt = 1; - -/* IVT is M by M */ - - il = ivt + *m * *m; - if (*lwork >= *m * *n + *m * *m + *m * 3 + bdspac) { - -/* WORK(IL) is M by N */ - - ldwrkl = *m; - chunk = *n; - } else { - ldwrkl = *m; - chunk = (*lwork - *m * *m) / *m; - } - itau = il + ldwrkl * *m; - nwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__1 = *lwork - nwork + 1; - sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Copy L to WORK(IL), zeroing about above it */ - - slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl); - i__1 = *m - 1; - i__2 = *m - 1; - slaset_("U", &i__1, &i__2, &c_b227, &c_b227, &work[il + - ldwrkl], &ldwrkl); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__1 = *lwork - nwork + 1; - sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], - &i__1, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in WORK(IL) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__1 = *lwork - nwork + 1; - sgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U, and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M+M*M+BDSPAC) */ - - sbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], m, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of L and WORK(IVT) */ -/* by right singular vectors of L */ -/* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */ - - i__1 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - sormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[ - itaup], &work[ivt], m, &work[nwork], &i__1, &ierr); - -/* Multiply right singular vectors of L in WORK(IVT) by Q */ -/* in A, storing result in WORK(IL) and copying to A */ -/* (Workspace: need 2*M*M, prefer M*M+M*N) */ - - i__1 = *n; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = *n - i__ + 1; - blk = min(i__3,chunk); - sgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], m, &a[ - i__ * a_dim1 + 1], lda, &c_b227, &work[il], & - ldwrkl); - slacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1 - + 1], lda); -/* L30: */ - } - - } else if (wntqs) { - -/* Path 3t (N much larger than M, JOBZ='S') */ -/* M right singular vectors to be computed in VT and */ -/* M left singular vectors to be computed in U */ - - il = 1; - -/* WORK(IL) is M by M */ - - ldwrkl = *m; - itau = il + ldwrkl * *m; - nwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - -/* Copy L to WORK(IL), zeroing out above it */ - - slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl); - i__2 = *m - 1; - i__1 = *m - 1; - slaset_("U", &i__2, &i__1, &c_b227, &c_b227, &work[il + - ldwrkl], &ldwrkl); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], - &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in WORK(IU), copying result to U */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - nwork + 1; - sgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - sbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of L and VT */ -/* by right singular vectors of L */ -/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - i__2 = *lwork - nwork + 1; - sormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply right singular vectors of L in WORK(IL) by */ -/* Q in A, storing result in VT */ -/* (Workspace: need M*M) */ - - slacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl); - sgemm_("N", "N", m, n, m, &c_b248, &work[il], &ldwrkl, &a[ - a_offset], lda, &c_b227, &vt[vt_offset], ldvt); - - } else if (wntqa) { - -/* Path 4t (N much larger than M, JOBZ='A') */ -/* N right singular vectors to be computed in VT and */ -/* M left singular vectors to be computed in U */ - - ivt = 1; - -/* WORK(IVT) is M by M */ - - ldwkvt = *m; - itau = ivt + ldwkvt * *m; - nwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); - -/* Generate Q in VT */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[ - nwork], &i__2, &ierr); - -/* Produce L in A, zeroing out other entries */ - - i__2 = *m - 1; - i__1 = *m - 1; - slaset_("U", &i__2, &i__1, &c_b227, &c_b227, &a[(a_dim1 << 1) - + 1], lda); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in A */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - nwork + 1; - sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M+M*M+BDSPAC) */ - - sbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1] -, info); - -/* Overwrite U by left singular vectors of L and WORK(IVT) */ -/* by right singular vectors of L */ -/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, m, m, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - i__2 = *lwork - nwork + 1; - sormbr_("P", "R", "T", m, m, m, &a[a_offset], lda, &work[ - itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, & - ierr); - -/* Multiply right singular vectors of L in WORK(IVT) by */ -/* Q in VT, storing result in A */ -/* (Workspace: need M*M) */ - - sgemm_("N", "N", m, n, m, &c_b248, &work[ivt], &ldwkvt, &vt[ - vt_offset], ldvt, &c_b227, &a[a_offset], lda); - -/* Copy right singular vectors of A from A to VT */ - - slacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); - - } - - } else { - -/* N .LT. MNTHR */ - -/* Path 5t (N greater than M, but not much larger) */ -/* Reduce to bidiagonal form without LQ decomposition */ - - 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__2 = *lwork - nwork + 1; - sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__2, &ierr); - if (wntqn) { - -/* Perform bidiagonal SVD, only computing singular values */ -/* (Workspace: need M+BDSPAC) */ - - sbdsdc_("L", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - } else if (wntqo) { - ldwkvt = *m; - ivt = nwork; - if (*lwork >= *m * *n + *m * 3 + bdspac) { - -/* WORK( IVT ) is M by N */ - - slaset_("F", m, n, &c_b227, &c_b227, &work[ivt], &ldwkvt); - nwork = ivt + ldwkvt * *n; - } else { - -/* WORK( IVT ) is M by M */ - - nwork = ivt + ldwkvt * *m; - il = nwork; - -/* WORK(IL) is M by CHUNK */ - - chunk = (*lwork - *m * *m - *m * 3) / *m; - } - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M*M+BDSPAC) */ - - sbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1] -, info); - -/* Overwrite U by left singular vectors of A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - - if (*lwork >= *m * *n + *m * 3 + bdspac) { - -/* Overwrite WORK(IVT) by left singular vectors of A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[ - itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, - &ierr); - -/* Copy right singular vectors of A from WORK(IVT) to A */ - - slacpy_("F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda); - } else { - -/* Generate P**T in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - sorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], & - work[nwork], &i__2, &ierr); - -/* Multiply Q in A by right singular vectors of */ -/* bidiagonal matrix in WORK(IVT), storing result in */ -/* WORK(IL) and copying to A */ -/* (Workspace: need 2*M*M, prefer M*M+M*N) */ - - i__2 = *n; - i__1 = chunk; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { -/* Computing MIN */ - i__3 = *n - i__ + 1; - blk = min(i__3,chunk); - sgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], & - ldwkvt, &a[i__ * a_dim1 + 1], lda, &c_b227, & - work[il], m); - slacpy_("F", m, &blk, &work[il], m, &a[i__ * a_dim1 + - 1], lda); -/* L40: */ - } - } - } else if (wntqs) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - slaset_("F", m, n, &c_b227, &c_b227, &vt[vt_offset], ldvt); - sbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 3*M, prefer 2*M+M*NB) */ - - i__1 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - sormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } else if (wntqa) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - slaset_("F", n, n, &c_b227, &c_b227, &vt[vt_offset], ldvt); - sbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Set the right corner of VT to identity matrix */ - - if (*n > *m) { - i__1 = *n - *m; - i__2 = *n - *m; - slaset_("F", &i__1, &i__2, &c_b227, &c_b248, &vt[*m + 1 + - (*m + 1) * vt_dim1], ldvt); - } - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 2*M+N, prefer 2*M+N*NB) */ - - i__1 = *lwork - nwork + 1; - sormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - sormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } - - } - - } - -/* Undo scaling if necessary */ - - if (iscl == 1) { - if (anrm > bignum) { - slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr); - } - if (anrm < smlnum) { - slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr); - } - } - -/* Return optimal workspace in WORK(1) */ - - work[1] = (real) maxwrk; - - return 0; - -/* End of SGESDD */ - -} /* sgesdd_ */ diff --git a/3rdparty/lapack/sgesv.c b/3rdparty/lapack/sgesv.c deleted file mode 100644 index b12beeb..0000000 --- a/3rdparty/lapack/sgesv.c +++ /dev/null @@ -1,139 +0,0 @@ -/* sgesv.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 sgesv_(integer *n, integer *nrhs, real *a, integer *lda, - integer *ipiv, real *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - extern /* Subroutine */ int xerbla_(char *, integer *), sgetrf_( - integer *, integer *, real *, integer *, integer *, integer *), - sgetrs_(char *, integer *, integer *, real *, integer *, integer * -, real *, 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 */ -/* ======= */ - -/* SGESV 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) REAL 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) REAL 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_("SGESV ", &i__1); - return 0; - } - -/* Compute the LU factorization of A. */ - - sgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - sgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[ - b_offset], ldb, info); - } - return 0; - -/* End of SGESV */ - -} /* sgesv_ */ diff --git a/3rdparty/lapack/sgetf2.c b/3rdparty/lapack/sgetf2.c deleted file mode 100644 index 4fbe523..0000000 --- a/3rdparty/lapack/sgetf2.c +++ /dev/null @@ -1,192 +0,0 @@ -/* sgetf2.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 real c_b8 = -1.f; - -/* Subroutine */ int sgetf2_(integer *m, integer *n, real *a, integer *lda, - integer *ipiv, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - real r__1; - - /* Local variables */ - integer i__, j, jp; - extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, - integer *, real *, integer *, real *, integer *), sscal_(integer * -, real *, real *, integer *); - real sfmin; - extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, - integer *); - extern doublereal slamch_(char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer isamax_(integer *, real *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGETF2 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) REAL 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_("SGETF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Compute machine safe minimum */ - - sfmin = slamch_("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 + isamax_(&i__2, &a[j + j * a_dim1], &c__1); - ipiv[j] = jp; - if (a[jp + j * a_dim1] != 0.f) { - -/* Apply the interchange to columns 1:N. */ - - if (jp != j) { - sswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda); - } - -/* Compute elements J+1:M of J-th column. */ - - if (j < *m) { - if ((r__1 = a[j + j * a_dim1], dabs(r__1)) >= sfmin) { - i__2 = *m - j; - r__1 = 1.f / a[j + j * a_dim1]; - sscal_(&i__2, &r__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; - sger_(&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 SGETF2 */ - -} /* sgetf2_ */ diff --git a/3rdparty/lapack/sgetrf.c b/3rdparty/lapack/sgetrf.c deleted file mode 100644 index 4f570bf..0000000 --- a/3rdparty/lapack/sgetrf.c +++ /dev/null @@ -1,217 +0,0 @@ -/* sgetrf.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 real c_b16 = 1.f; -static real c_b19 = -1.f; - -/* Subroutine */ int sgetrf_(integer *m, integer *n, real *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, iinfo; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *), strsm_(char *, char *, char *, - char *, integer *, integer *, real *, real *, integer *, real *, - integer *), sgetf2_(integer *, - integer *, real *, integer *, integer *, integer *), xerbla_(char - *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slaswp_(integer *, real *, 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 */ -/* ======= */ - -/* SGETRF 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) REAL 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_("SGETRF", &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, "SGETRF", " ", m, n, &c_n1, &c_n1); - if (nb <= 1 || nb >= min(*m,*n)) { - -/* Use unblocked code. */ - - sgetf2_(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; - sgetf2_(&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; - slaswp_(&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; - slaswp_(&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; - strsm_("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; - sgemm_("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 SGETRF */ - -} /* sgetrf_ */ diff --git a/3rdparty/lapack/sgetri.c b/3rdparty/lapack/sgetri.c deleted file mode 100644 index db435fc..0000000 --- a/3rdparty/lapack/sgetri.c +++ /dev/null @@ -1,259 +0,0 @@ -/* sgetri.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 real c_b20 = -1.f; -static real c_b22 = 1.f; - -/* Subroutine */ int sgetri_(integer *n, real *a, integer *lda, integer *ipiv, - real *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, nbmin; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *), sgemv_(char *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *), sswap_(integer *, real *, integer *, - real *, integer *), strsm_(char *, char *, char *, char *, - integer *, integer *, real *, real *, integer *, real *, integer * -), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - integer ldwork, lwkopt; - logical lquery; - extern /* Subroutine */ int strtri_(char *, char *, integer *, real *, - integer *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGETRI computes the inverse of a matrix using the LU factorization */ -/* computed by SGETRF. */ - -/* 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) REAL array, dimension (LDA,N) */ -/* On entry, the factors L and U from the factorization */ -/* A = P*L*U as computed by SGETRF. */ -/* 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 SGETRF; for 1<=i<=N, row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* WORK (workspace/output) REAL 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, "SGETRI", " ", n, &c_n1, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (real) 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_("SGETRI", &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 STRTRI, then U is singular, */ -/* and the inverse is not computed. */ - - strtri_("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, "SGETRI", " ", 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.f; -/* L10: */ - } - -/* Compute current column of inv(A). */ - - if (j < *n) { - i__1 = *n - j; - sgemv_("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.f; -/* L30: */ - } -/* L40: */ - } - -/* Compute current block column of inv(A). */ - - if (j + jb <= *n) { - i__2 = *n - j - jb + 1; - sgemm_("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); - } - strsm_("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) { - sswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1); - } -/* L60: */ - } - - work[1] = (real) iws; - return 0; - -/* End of SGETRI */ - -} /* sgetri_ */ diff --git a/3rdparty/lapack/sgetrs.c b/3rdparty/lapack/sgetrs.c deleted file mode 100644 index 3bfdb62..0000000 --- a/3rdparty/lapack/sgetrs.c +++ /dev/null @@ -1,185 +0,0 @@ -/* sgetrs.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 real c_b12 = 1.f; -static integer c_n1 = -1; - -/* Subroutine */ int sgetrs_(char *trans, integer *n, integer *nrhs, real *a, - integer *lda, integer *ipiv, real *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 strsm_(char *, char *, char *, char *, - integer *, integer *, real *, real *, integer *, real *, integer * -), xerbla_(char *, integer *); - logical notran; - extern /* Subroutine */ int slaswp_(integer *, real *, 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 */ -/* ======= */ - -/* SGETRS 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 SGETRF. */ - -/* 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) REAL array, dimension (LDA,N) */ -/* The factors L and U from the factorization A = P*L*U */ -/* as computed by SGETRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from SGETRF; for 1<=i<=N, row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* B (input/output) REAL 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_("SGETRS", &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. */ - - slaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); - -/* Solve L*X = B, overwriting B with X. */ - - strsm_("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. */ - - strsm_("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. */ - - strsm_("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. */ - - strsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Apply row interchanges to the solution vectors. */ - - slaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); - } - - return 0; - -/* End of SGETRS */ - -} /* sgetrs_ */ diff --git a/3rdparty/lapack/slabad.c b/3rdparty/lapack/slabad.c deleted file mode 100644 index e6f6c25..0000000 --- a/3rdparty/lapack/slabad.c +++ /dev/null @@ -1,72 +0,0 @@ -/* slabad.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 slabad_(real *small, real *large) -{ - /* Builtin functions */ - double r_lg10(real *), sqrt(doublereal); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLABAD takes as input the values computed by SLAMCH 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 SLAMCH. This subroutine is needed because */ -/* SLAMCH does not compensate for poor arithmetic in the upper half of */ -/* the exponent range, as is found on a Cray. */ - -/* Arguments */ -/* ========= */ - -/* SMALL (input/output) REAL */ -/* On entry, the underflow threshold as computed by SLAMCH. */ -/* On exit, if LOG10(LARGE) is sufficiently large, the square */ -/* root of SMALL, otherwise unchanged. */ - -/* LARGE (input/output) REAL */ -/* On entry, the overflow threshold as computed by SLAMCH. */ -/* 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 (r_lg10(large) > 2e3f) { - *small = sqrt(*small); - *large = sqrt(*large); - } - - return 0; - -/* End of SLABAD */ - -} /* slabad_ */ diff --git a/3rdparty/lapack/slabrd.c b/3rdparty/lapack/slabrd.c deleted file mode 100644 index 43b5dd7..0000000 --- a/3rdparty/lapack/slabrd.c +++ /dev/null @@ -1,432 +0,0 @@ -/* slabrd.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 real c_b4 = -1.f; -static real c_b5 = 1.f; -static integer c__1 = 1; -static real c_b16 = 0.f; - -/* Subroutine */ int slabrd_(integer *m, integer *n, integer *nb, real *a, - integer *lda, real *d__, real *e, real *tauq, real *taup, real *x, - integer *ldx, real *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 sscal_(integer *, real *, real *, integer *), - sgemv_(char *, integer *, integer *, real *, real *, integer *, - real *, integer *, real *, real *, integer *), slarfg_( - integer *, real *, real *, integer *, real *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLABRD 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 SGEBRD */ - -/* 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) REAL 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) REAL array, dimension (NB) */ -/* The diagonal elements of the first NB rows and columns of */ -/* the reduced matrix. D(i) = A(i,i). */ - -/* E (output) REAL array, dimension (NB) */ -/* The off-diagonal elements of the first NB rows and columns of */ -/* the reduced matrix. */ - -/* TAUQ (output) REAL array dimension (NB) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Q. See Further Details. */ - -/* TAUP (output) REAL array, dimension (NB) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix P. See Further Details. */ - -/* X (output) REAL 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) REAL 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; - sgemv_("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; - sgemv_("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; - slarfg_(&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.f; - -/* Compute Y(i+1:n,i) */ - - i__2 = *m - i__ + 1; - i__3 = *n - i__; - sgemv_("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; - sgemv_("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; - sgemv_("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; - sgemv_("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__; - sgemv_("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__; - sscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); - -/* Update A(i,i+1:n) */ - - i__2 = *n - i__; - sgemv_("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__; - sgemv_("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; - slarfg_(&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.f; - -/* Compute X(i+1:m,i) */ - - i__2 = *m - i__; - i__3 = *n - i__; - sgemv_("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__; - sgemv_("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__; - sgemv_("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__; - sgemv_("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; - sgemv_("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__; - sscal_(&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; - sgemv_("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; - sgemv_("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; - slarfg_(&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.f; - -/* Compute X(i+1:m,i) */ - - i__2 = *m - i__; - i__3 = *n - i__ + 1; - sgemv_("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; - sgemv_("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; - sgemv_("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; - sgemv_("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; - sgemv_("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__; - sscal_(&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; - sgemv_("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__; - sgemv_("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; - slarfg_(&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.f; - -/* Compute Y(i+1:n,i) */ - - i__2 = *m - i__; - i__3 = *n - i__; - sgemv_("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; - sgemv_("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; - sgemv_("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__; - sgemv_("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__; - sgemv_("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__; - sscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); - } -/* L20: */ - } - } - return 0; - -/* End of SLABRD */ - -} /* slabrd_ */ diff --git a/3rdparty/lapack/slacpy.c b/3rdparty/lapack/slacpy.c deleted file mode 100644 index 529168e..0000000 --- a/3rdparty/lapack/slacpy.c +++ /dev/null @@ -1,125 +0,0 @@ -/* slacpy.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 slacpy_(char *uplo, integer *m, integer *n, real *a, - integer *lda, real *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 */ -/* ======= */ - -/* SLACPY 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) REAL 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) REAL 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 SLACPY */ - -} /* slacpy_ */ diff --git a/3rdparty/lapack/slae2.c b/3rdparty/lapack/slae2.c deleted file mode 100644 index 021bc3f..0000000 --- a/3rdparty/lapack/slae2.c +++ /dev/null @@ -1,141 +0,0 @@ -/* slae2.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 slae2_(real *a, real *b, real *c__, real *rt1, real *rt2) -{ - /* System generated locals */ - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real 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 */ -/* ======= */ - -/* SLAE2 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) REAL */ -/* The (1,1) element of the 2-by-2 matrix. */ - -/* B (input) REAL */ -/* The (1,2) and (2,1) elements of the 2-by-2 matrix. */ - -/* C (input) REAL */ -/* The (2,2) element of the 2-by-2 matrix. */ - -/* RT1 (output) REAL */ -/* The eigenvalue of larger absolute value. */ - -/* RT2 (output) REAL */ -/* 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 = dabs(df); - tb = *b + *b; - ab = dabs(tb); - if (dabs(*a) > dabs(*c__)) { - acmx = *a; - acmn = *c__; - } else { - acmx = *c__; - acmn = *a; - } - if (adf > ab) { -/* Computing 2nd power */ - r__1 = ab / adf; - rt = adf * sqrt(r__1 * r__1 + 1.f); - } else if (adf < ab) { -/* Computing 2nd power */ - r__1 = adf / ab; - rt = ab * sqrt(r__1 * r__1 + 1.f); - } else { - -/* Includes case AB=ADF=0 */ - - rt = ab * sqrt(2.f); - } - if (sm < 0.f) { - *rt1 = (sm - rt) * .5f; - -/* 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.f) { - *rt1 = (sm + rt) * .5f; - -/* 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 * .5f; - *rt2 = rt * -.5f; - } - return 0; - -/* End of SLAE2 */ - -} /* slae2_ */ diff --git a/3rdparty/lapack/slaebz.c b/3rdparty/lapack/slaebz.c deleted file mode 100644 index e169b57..0000000 --- a/3rdparty/lapack/slaebz.c +++ /dev/null @@ -1,639 +0,0 @@ -/* slaebz.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 slaebz_(integer *ijob, integer *nitmax, integer *n, - integer *mmax, integer *minp, integer *nbmin, real *abstol, real * - reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval, - real *ab, real *c__, integer *mout, integer *nab, real *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; - real r__1, r__2, r__3, r__4; - - /* Local variables */ - integer j, kf, ji, kl, jp, jit; - real 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 */ -/* ======= */ - -/* SLAEBZ 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 SLAEBZ 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 SLAEBZ 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) REAL */ -/* 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) REAL */ -/* 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) REAL */ -/* 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) REAL array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T. */ - -/* E (input) REAL array, dimension (N) */ -/* The offdiagonal elements of the tridiagonal matrix T in */ -/* positions 1 through N-1. E(N) is arbitrary. */ - -/* E2 (input) REAL 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) REAL 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) REAL 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 SLAEBZ 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 SLAEBZ is called. */ - -/* WORK (workspace) REAL 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, SLAEBZ should have one or */ -/* more initial intervals set up in AB, and SLAEBZ 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. SLAEBZ 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). SLAEBZ 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 (dabs(tmp1) < *pivmin) { - tmp1 = -(*pivmin); - } - nab[ji + jp * nab_dim1] = 0; - if (tmp1 <= 0.f) { - 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 (dabs(tmp1) < *pivmin) { - tmp1 = -(*pivmin); - } - if (tmp1 <= 0.f) { - ++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)]) * .5f; -/* 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 */ - r__1 = work[ji], r__2 = -(*pivmin); - work[ji] = dmin(r__1,r__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 */ - r__1 = work[ji], r__2 = -(*pivmin); - work[ji] = dmin(r__1,r__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 */ - r__1 = tmp2, r__2 = -(*pivmin); - tmp2 = dmin(r__1,r__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 */ - r__1 = tmp2, r__2 = -(*pivmin); - tmp2 = dmin(r__1,r__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 = (r__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], dabs( - r__1)); -/* Computing MAX */ - r__3 = (r__1 = ab[ji + (ab_dim1 << 1)], dabs(r__1)), r__4 = (r__2 - = ab[ji + ab_dim1], dabs(r__2)); - tmp2 = dmax(r__3,r__4); -/* Computing MAX */ - r__1 = max(*abstol,*pivmin), r__2 = *reltol * tmp2; - if (tmp1 < dmax(r__1,r__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)]) * .5f; -/* 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 SLAEBZ */ - -} /* slaebz_ */ diff --git a/3rdparty/lapack/slaed0.c b/3rdparty/lapack/slaed0.c deleted file mode 100644 index 96228e7..0000000 --- a/3rdparty/lapack/slaed0.c +++ /dev/null @@ -1,435 +0,0 @@ -/* slaed0.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 real c_b23 = 1.f; -static real c_b24 = 0.f; -static integer c__1 = 1; - -/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real - *d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs, - real *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; - real r__1; - - /* Builtin functions */ - double log(doublereal); - integer pow_ii(integer *, integer *); - - /* Local variables */ - integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2; - real temp; - integer curr; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - integer iperm, indxq, iwrem; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - integer iqptr, tlvls; - extern /* Subroutine */ int slaed1_(integer *, real *, real *, integer *, - integer *, real *, integer *, real *, integer *, integer *), - slaed7_(integer *, integer *, integer *, integer *, integer *, - integer *, real *, real *, integer *, integer *, real *, integer * -, real *, integer *, integer *, integer *, integer *, integer *, - real *, real *, integer *, integer *); - integer igivcl; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - integer igivnm, submat; - extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, - integer *, real *, integer *); - integer curprb, subpbs, igivpt, curlvl, matsiz, iprmpt, smlsiz; - extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, - real *, integer *, real *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAED0 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) REAL array, dimension (N) */ -/* On entry, the main diagonal of the tridiagonal matrix. */ -/* On exit, its eigenvalues. */ - -/* E (input) REAL array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* Q (input/output) REAL 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) REAL 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) REAL 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_("SLAED0", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - smlsiz = ilaenv_(&c__9, "SLAED0", " ", &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] -= (r__1 = e[smm1], dabs(r__1)); - d__[submat] -= (r__1 = e[smm1], dabs(r__1)); -/* L40: */ - } - - indxq = (*n << 2) + 3; - if (*icompq != 2) { - -/* Set up workspaces for eigenvalues only/accumulate new vectors */ -/* routine */ - - temp = log((real) (*n)) / log(2.f); - 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) { - ssteqr_("I", &matsiz, &d__[submat], &e[submat], &q[submat + - submat * q_dim1], ldq, &work[1], info); - if (*info != 0) { - goto L130; - } - } else { - ssteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + - iwork[iqptr + curr]], &matsiz, &work[1], info); - if (*info != 0) { - goto L130; - } - if (*icompq == 1) { - sgemm_("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. */ -/* SLAED1 is used only for the full eigensystem of a tridiagonal */ -/* matrix. */ -/* SLAED7 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) { - slaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], - ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], & - msd2, &work[1], &iwork[subpbs + 1], info); - } else { - slaed7_(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]; - scopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 - + 1], &c__1); -/* L100: */ - } - scopy_(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]; - scopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); -/* L110: */ - } - scopy_(n, &work[1], &c__1, &d__[1], &c__1); - slacpy_("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: */ - } - scopy_(n, &work[1], &c__1, &d__[1], &c__1); - } - goto L140; - -L130: - *info = submat * (*n + 1) + submat + matsiz - 1; - -L140: - return 0; - -/* End of SLAED0 */ - -} /* slaed0_ */ diff --git a/3rdparty/lapack/slaed1.c b/3rdparty/lapack/slaed1.c deleted file mode 100644 index 1c307af..0000000 --- a/3rdparty/lapack/slaed1.c +++ /dev/null @@ -1,246 +0,0 @@ -/* slaed1.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 slaed1_(integer *n, real *d__, real *q, integer *ldq, - integer *indxq, real *rho, integer *cutpnt, real *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, cpp1, indx, indxc, indxp; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), slaed2_(integer *, integer *, integer *, real *, real - *, integer *, integer *, real *, real *, real *, real *, real *, - integer *, integer *, integer *, integer *, integer *), slaed3_( - integer *, integer *, integer *, real *, real *, integer *, real * -, real *, real *, integer *, integer *, real *, real *, integer *) - ; - integer idlmda; - extern /* Subroutine */ int xerbla_(char *, integer *), slamrg_( - integer *, integer *, real *, integer *, integer *, 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 */ -/* ======= */ - -/* SLAED1 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. SLAED7 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 SLAED2. */ - -/* The second stage consists of calculating the updated */ -/* eigenvalues. This is done by finding the roots of the secular */ -/* equation via the routine SLAED4 (as called by SLAED3). */ -/* 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) REAL array, dimension (N) */ -/* On entry, the eigenvalues of the rank-1-perturbed matrix. */ -/* On exit, the eigenvalues of the repaired matrix. */ - -/* Q (input/output) REAL 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) REAL */ -/* 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) REAL 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_("SLAED1", &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 SLAED2 and SLAED3. */ - - 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. */ - - scopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1); - cpp1 = *cutpnt + 1; - i__1 = *n - *cutpnt; - scopy_(&i__1, &q[cpp1 + cpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1); - -/* Deflate eigenvalues. */ - - slaed2_(&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; - slaed3_(&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; - slamrg_(&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 SLAED1 */ - -} /* slaed1_ */ diff --git a/3rdparty/lapack/slaed2.c b/3rdparty/lapack/slaed2.c deleted file mode 100644 index 9736d4e..0000000 --- a/3rdparty/lapack/slaed2.c +++ /dev/null @@ -1,530 +0,0 @@ -/* slaed2.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 real c_b3 = -1.f; -static integer c__1 = 1; - -/* Subroutine */ int slaed2_(integer *k, integer *n, integer *n1, real *d__, - real *q, integer *ldq, integer *indxq, real *rho, real *z__, real * - dlamda, real *w, real *q2, integer *indx, integer *indxc, integer * - indxp, integer *coltyp, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, i__1, i__2; - real r__1, r__2, r__3, r__4; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real c__; - integer i__, j; - real s, t; - integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1; - real eps, tau, tol; - integer psm[4], imax, jmax, ctot[4]; - extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, - integer *, real *, real *), sscal_(integer *, real *, real *, - integer *), scopy_(integer *, real *, integer *, real *, integer * -); - extern doublereal slapy2_(real *, real *), slamch_(char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer isamax_(integer *, real *, integer *); - extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer - *, integer *, integer *), slacpy_(char *, integer *, integer *, - real *, integer *, real *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAED2 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) REAL 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) REAL 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) REAL */ -/* 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 */ -/* SLAED3. */ - -/* Z (input) REAL 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) REAL array, dimension (N) */ -/* A copy of the first K eigenvalues which will be used by */ -/* SLAED3 to form the secular equation. */ - -/* W (output) REAL array, dimension (N) */ -/* The first k values of the final deflation-altered z-vector */ -/* which will be passed to SLAED3. */ - -/* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2) */ -/* A copy of the first K eigenvectors which will be used by */ -/* SLAED3 in a matrix multiply (SGEMM) 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_("SLAED2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - n2 = *n - *n1; - n1p1 = *n1 + 1; - - if (*rho < 0.f) { - sscal_(&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.f / sqrt(2.f); - sscal_(n, &t, &z__[1], &c__1); - -/* RHO = ABS( norm(z)**2 * RHO ) */ - - *rho = (r__1 = *rho * 2.f, dabs(r__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: */ - } - slamrg_(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 = isamax_(n, &z__[1], &c__1); - jmax = isamax_(n, &d__[1], &c__1); - eps = slamch_("Epsilon"); -/* Computing MAX */ - r__3 = (r__1 = d__[jmax], dabs(r__1)), r__4 = (r__2 = z__[imax], dabs( - r__2)); - tol = eps * 8.f * dmax(r__3,r__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 * (r__1 = z__[imax], dabs(r__1)) <= tol) { - *k = 0; - iq2 = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__ = indx[j]; - scopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); - dlamda[j] = d__[i__]; - iq2 += *n; -/* L40: */ - } - slacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq); - scopy_(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 * (r__1 = z__[nj], dabs(r__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 * (r__1 = z__[nj], dabs(r__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 = slapy2_(&c__, &s); - t = d__[nj] - d__[pj]; - c__ /= tau; - s = -s / tau; - if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) { - -/* Deflation is possible. */ - - z__[nj] = tau; - z__[pj] = 0.f; - if (coltyp[nj] != coltyp[pj]) { - coltyp[nj] = 2; - } - coltyp[pj] = 4; - srot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, & - c__, &s); -/* Computing 2nd power */ - r__1 = c__; -/* Computing 2nd power */ - r__2 = s; - t = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2); -/* Computing 2nd power */ - r__1 = s; -/* Computing 2nd power */ - r__2 = c__; - d__[nj] = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__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__]; - scopy_(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__]; - scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); - scopy_(&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__]; - scopy_(&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__]; - scopy_(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. */ - - slacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq); - i__1 = *n - *k; - scopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); - -/* Copy CTOT into COLTYP for referencing in SLAED3. */ - - for (j = 1; j <= 4; ++j) { - coltyp[j] = ctot[j - 1]; -/* L180: */ - } - -L190: - return 0; - -/* End of SLAED2 */ - -} /* slaed2_ */ diff --git a/3rdparty/lapack/slaed3.c b/3rdparty/lapack/slaed3.c deleted file mode 100644 index 0603930..0000000 --- a/3rdparty/lapack/slaed3.c +++ /dev/null @@ -1,336 +0,0 @@ -/* slaed3.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 real c_b22 = 1.f; -static real c_b23 = 0.f; - -/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__, - real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer * - indx, integer *ctot, real *w, real *s, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, i__1, i__2; - real r__1; - - /* Builtin functions */ - double sqrt(doublereal), r_sign(real *, real *); - - /* Local variables */ - integer i__, j, n2, n12, ii, n23, iq2; - real temp; - extern doublereal snrm2_(integer *, real *, integer *); - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *), scopy_(integer *, real *, - integer *, real *, integer *), slaed4_(integer *, integer *, real - *, real *, real *, real *, real *, integer *); - extern doublereal slamc3_(real *, real *); - extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_( - char *, integer *, integer *, real *, integer *, real *, integer * -), slaset_(char *, integer *, integer *, real *, real *, - real *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAED3 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 SLAED4 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 */ -/* SLAED4. 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) REAL array, dimension (N) */ -/* D(I) contains the updated eigenvalues for */ -/* 1 <= I <= K. */ - -/* Q (output) REAL 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) REAL */ -/* The value of the parameter in the rank one update equation. */ -/* RHO >= 0 required. */ - -/* DLAMDA (input/output) REAL 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) REAL 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 SLAED2). */ -/* The rows of the eigenvectors found by SLAED4 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) REAL array, dimension (K) */ -/* The first K elements of this array contain the components */ -/* of the deflation-adjusted updating vector. Destroyed on */ -/* output. */ - -/* S (workspace) REAL 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_("SLAED3", &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__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; -/* L10: */ - } - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - slaed4_(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. */ - - scopy_(k, &w[1], &c__1, &s[1], &c__1); - -/* Initialize W(I) = Q(I,I) */ - - i__1 = *ldq + 1; - scopy_(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__) { - r__1 = sqrt(-w[i__]); - w[i__] = r_sign(&r__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 = snrm2_(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]; - - slacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23); - iq2 = *n1 * n12 + 1; - if (n23 != 0) { - sgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & - c_b23, &q[*n1 + 1 + q_dim1], ldq); - } else { - slaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq); - } - - slacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12); - if (n12 != 0) { - sgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, - &q[q_offset], ldq); - } else { - slaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq); - } - - -L120: - return 0; - -/* End of SLAED3 */ - -} /* slaed3_ */ diff --git a/3rdparty/lapack/slaed4.c b/3rdparty/lapack/slaed4.c deleted file mode 100644 index 355e9de..0000000 --- a/3rdparty/lapack/slaed4.c +++ /dev/null @@ -1,952 +0,0 @@ -/* slaed4.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 slaed4_(integer *n, integer *i__, real *d__, real *z__, - real *delta, real *rho, real *dlam, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real a, b, c__; - integer j; - real w; - integer ii; - real dw, zz[3]; - integer ip1; - real del, eta, phi, eps, tau, psi; - integer iim1, iip1; - real dphi, dpsi; - integer iter; - real temp, prew, temp1, dltlb, dltub, midpt; - integer niter; - logical swtch; - extern /* Subroutine */ int slaed5_(integer *, real *, real *, real *, - real *, real *), slaed6_(integer *, logical *, real *, real *, - real *, real *, real *, integer *); - logical swtch3; - extern doublereal slamch_(char *); - logical orgati; - real 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) REAL array, dimension (N) */ -/* The original eigenvalues. It is assumed that they are in */ -/* order, D(I) < D(J) for I < J. */ - -/* Z (input) REAL array, dimension (N) */ -/* The components of the updating vector. */ - -/* DELTA (output) REAL 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 SLAED5 */ -/* for detail. The vector DELTA contains the information necessary */ -/* to construct the eigenvectors by SLAED3 and SLAED9. */ - -/* RHO (input) REAL */ -/* The scalar in the symmetric updating formula. */ - -/* DLAM (output) REAL */ -/* 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.f; - return 0; - } - if (*n == 2) { - slaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam); - return 0; - } - -/* Compute machine epsilon */ - - eps = slamch_("Epsilon"); - rhoinv = 1.f / *rho; - -/* The case I = N */ - - if (*i__ == *n) { - -/* Initialize some basic variables */ - - ii = *n - 1; - niter = 1; - -/* Calculate initial guess */ - - midpt = *rho / 2.f; - -/* 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.f; - 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.f) { - 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.f) { - tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f); - } - } - -/* 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.f) { - tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f); - } - -/* It can be proved that */ -/* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */ - - dltlb = 0.f; - 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.f; - psi = 0.f; - erretm = 0.f; - 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 = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * ( - dpsi + dphi); - - w = rhoinv + phi + psi; - -/* Test for convergence */ - - if (dabs(w) <= eps * erretm) { - *dlam = d__[*i__] + tau; - goto L250; - } - - if (w <= 0.f) { - dltlb = dmax(dltlb,tau); - } else { - dltub = dmin(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.f) { - c__ = dabs(c__); - } - if (c__ == 0.f) { -/* ETA = B/A */ -/* ETA = RHO - TAU */ - eta = dltub - tau; - } else if (a >= 0.f) { - eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / ( - c__ * 2.f); - } else { - eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__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.f) { - eta = -w / (dpsi + dphi); - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.f) { - eta = (dltub - tau) / 2.f; - } else { - eta = (dltlb - tau) / 2.f; - } - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; -/* L50: */ - } - - tau += eta; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - 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 = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(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 (dabs(w) <= eps * erretm) { - *dlam = d__[*i__] + tau; - goto L250; - } - - if (w <= 0.f) { - dltlb = dmax(dltlb,tau); - } else { - dltub = dmin(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.f) { - eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / - (c__ * 2.f); - } else { - eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__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.f) { - eta = -w / (dpsi + dphi); - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.f) { - eta = (dltub - tau) / 2.f; - } else { - eta = (dltlb - tau) / 2.f; - } - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; -/* L70: */ - } - - tau += eta; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - 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 = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(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.f; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - midpt; -/* L100: */ - } - - psi = 0.f; - i__1 = *i__ - 1; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / delta[j]; -/* L110: */ - } - - phi = 0.f; - 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.f) { - -/* 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.f) { - tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__1)))); - } else { - tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / - (c__ * 2.f); - } - dltlb = 0.f; - 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.f) { - tau = b * 2.f / (a - sqrt((r__1 = a * a + b * 4.f * c__, dabs( - r__1)))); - } else { - tau = -(a + sqrt((r__1 = a * a + b * 4.f * c__, dabs(r__1)))) - / (c__ * 2.f); - } - dltlb = -midpt; - dltub = 0.f; - } - - 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.f; - psi = 0.f; - erretm = 0.f; - 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 = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.f; - phi = 0.f; - 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.f) { - swtch3 = TRUE_; - } - } else { - if (w > 0.f) { - 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.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f - + dabs(tau) * dw; - -/* Test for convergence */ - - if (dabs(w) <= eps * erretm) { - if (orgati) { - *dlam = d__[*i__] + tau; - } else { - *dlam = d__[ip1] + tau; - } - goto L250; - } - - if (w <= 0.f) { - dltlb = dmax(dltlb,tau); - } else { - dltub = dmin(dltub,tau); - } - -/* Calculate the new step */ - - ++niter; - if (! swtch3) { - if (orgati) { -/* Computing 2nd power */ - r__1 = z__[*i__] / delta[*i__]; - c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (r__1 * - r__1); - } else { -/* Computing 2nd power */ - r__1 = z__[ip1] / delta[ip1]; - c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (r__1 * - r__1); - } - a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * - dw; - b = delta[*i__] * delta[ip1] * w; - if (c__ == 0.f) { - if (a == 0.f) { - 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.f) { - eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / - (c__ * 2.f); - } else { - eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__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]; - slaed6_(&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.f) { - eta = -w / dw; - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.f) { - eta = (dltub - tau) / 2.f; - } else { - eta = (dltlb - tau) / 2.f; - } - } - - prew = w; - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; -/* L180: */ - } - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - 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 = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.f; - phi = 0.f; - 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.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f - + (r__1 = tau + eta, dabs(r__1)) * dw; - - swtch = FALSE_; - if (orgati) { - if (-w > dabs(prew) / 10.f) { - swtch = TRUE_; - } - } else { - if (w > dabs(prew) / 10.f) { - 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 (dabs(w) <= eps * erretm) { - if (orgati) { - *dlam = d__[*i__] + tau; - } else { - *dlam = d__[ip1] + tau; - } - goto L250; - } - - if (w <= 0.f) { - dltlb = dmax(dltlb,tau); - } else { - dltub = dmin(dltub,tau); - } - -/* Calculate the new step */ - - if (! swtch3) { - if (! swtch) { - if (orgati) { -/* Computing 2nd power */ - r__1 = z__[*i__] / delta[*i__]; - c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * ( - r__1 * r__1); - } else { -/* Computing 2nd power */ - r__1 = z__[ip1] / delta[ip1]; - c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * - (r__1 * r__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.f) { - if (a == 0.f) { - 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.f) { - eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)) - )) / (c__ * 2.f); - } else { - eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, - dabs(r__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]; - } - } - slaed6_(&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.f) { - eta = -w / dw; - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.f) { - eta = (dltub - tau) / 2.f; - } else { - eta = (dltlb - tau) / 2.f; - } - } - - 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.f; - psi = 0.f; - erretm = 0.f; - 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 = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.f; - phi = 0.f; - 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.f + erretm + rhoinv * 2.f + dabs(temp) * - 3.f + dabs(tau) * dw; - if (w * prew > 0.f && dabs(w) > dabs(prew) / 10.f) { - 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 SLAED4 */ - -} /* slaed4_ */ diff --git a/3rdparty/lapack/slaed5.c b/3rdparty/lapack/slaed5.c deleted file mode 100644 index aaf1880..0000000 --- a/3rdparty/lapack/slaed5.c +++ /dev/null @@ -1,149 +0,0 @@ -/* slaed5.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 slaed5_(integer *i__, real *d__, real *z__, real *delta, - real *rho, real *dlam) -{ - /* System generated locals */ - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real 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) REAL array, dimension (2) */ -/* The original eigenvalues. We assume D(1) < D(2). */ - -/* Z (input) REAL array, dimension (2) */ -/* The components of the updating vector. */ - -/* DELTA (output) REAL array, dimension (2) */ -/* The vector DELTA contains the information necessary */ -/* to construct the eigenvectors. */ - -/* RHO (input) REAL */ -/* The scalar in the symmetric updating formula. */ - -/* DLAM (output) REAL */ -/* 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.f * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.f; - if (w > 0.f) { - b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[1] * z__[1] * del; - -/* B > ZERO, always */ - - tau = c__ * 2.f / (b + sqrt((r__1 = b * b - c__ * 4.f, dabs(r__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.f) { - tau = c__ * -2.f / (b + sqrt(b * b + c__ * 4.f)); - } else { - tau = (b - sqrt(b * b + c__ * 4.f)) / 2.f; - } - *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.f) { - tau = (b + sqrt(b * b + c__ * 4.f)) / 2.f; - } else { - tau = c__ * 2.f / (-b + sqrt(b * b + c__ * 4.f)); - } - *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 SLAED5 */ - -} /* slaed5_ */ diff --git a/3rdparty/lapack/slaed6.c b/3rdparty/lapack/slaed6.c deleted file mode 100644 index 67c21a7..0000000 --- a/3rdparty/lapack/slaed6.c +++ /dev/null @@ -1,375 +0,0 @@ -/* slaed6.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 slaed6_(integer *kniter, logical *orgati, real *rho, - real *d__, real *z__, real *finit, real *tau, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2, r__3, r__4; - - /* Builtin functions */ - double sqrt(doublereal), log(doublereal), pow_ri(real *, integer *); - - /* Local variables */ - real a, b, c__, f; - integer i__; - real fc, df, ddf, lbd, eta, ubd, eps, base; - integer iter; - real temp, temp1, temp2, temp3, temp4; - logical scale; - integer niter; - real small1, small2, sminv1, sminv2, dscale[3], sclfac; - extern doublereal slamch_(char *); - real 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 */ -/* ======= */ - -/* SLAED6 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 SLAED4 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 SLAED4 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 */ -/* SLAED4 for further details. */ - -/* RHO (input) REAL */ -/* Refer to the equation f(x) above. */ - -/* D (input) REAL array, dimension (3) */ -/* D satisfies d(1) < d(2) < d(3). */ - -/* Z (input) REAL array, dimension (3) */ -/* Each of the elements in z must be positive. */ - -/* FINIT (input) REAL */ -/* 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) REAL */ -/* 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.f) { - lbd = 0.f; - } else { - ubd = 0.f; - } - - niter = 1; - *tau = 0.f; - if (*kniter == 2) { - if (*orgati) { - temp = (d__[3] - d__[2]) / 2.f; - 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.f; - 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 */ - r__1 = dabs(a), r__2 = dabs(b), r__1 = max(r__1,r__2), r__2 = dabs( - c__); - temp = dmax(r__1,r__2); - a /= temp; - b /= temp; - c__ /= temp; - if (c__ == 0.f) { - *tau = b / a; - } else if (a <= 0.f) { - *tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / ( - c__ * 2.f); - } else { - *tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__1)))); - } - if (*tau < lbd || *tau > ubd) { - *tau = (lbd + ubd) / 2.f; - } - if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { - *tau = 0.f; - } 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.f) { - lbd = *tau; - } else { - ubd = *tau; - } - if (dabs(*finit) <= dabs(temp)) { - *tau = 0.f; - } - } - } - -/* 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 = slamch_("Epsilon"); - base = slamch_("Base"); - i__1 = (integer) (log(slamch_("SafMin")) / log(base) / 3.f); - small1 = pow_ri(&base, &i__1); - sminv1 = 1.f / 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 */ - r__3 = (r__1 = d__[2] - *tau, dabs(r__1)), r__4 = (r__2 = d__[3] - * - tau, dabs(r__2)); - temp = dmin(r__3,r__4); - } else { -/* Computing MIN */ - r__3 = (r__1 = d__[1] - *tau, dabs(r__1)), r__4 = (r__2 = d__[2] - * - tau, dabs(r__2)); - temp = dmin(r__3,r__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.f; - df = 0.f; - ddf = 0.f; - for (i__ = 1; i__ <= 3; ++i__) { - temp = 1.f / (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 (dabs(f) <= 0.f) { - goto L60; - } - if (f <= 0.f) { - 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 */ - r__1 = dabs(a), r__2 = dabs(b), r__1 = max(r__1,r__2), r__2 = dabs( - c__); - temp = dmax(r__1,r__2); - a /= temp; - b /= temp; - c__ /= temp; - if (c__ == 0.f) { - eta = b / a; - } else if (a <= 0.f) { - eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / ( - c__ * 2.f); - } else { - eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__1)))); - } - if (f * eta >= 0.f) { - eta = -f / df; - } - - *tau += eta; - if (*tau < lbd || *tau > ubd) { - *tau = (lbd + ubd) / 2.f; - } - - fc = 0.f; - erretm = 0.f; - df = 0.f; - ddf = 0.f; - for (i__ = 1; i__ <= 3; ++i__) { - temp = 1.f / (dscale[i__ - 1] - *tau); - temp1 = zscale[i__ - 1] * temp; - temp2 = temp1 * temp; - temp3 = temp2 * temp; - temp4 = temp1 / dscale[i__ - 1]; - fc += temp4; - erretm += dabs(temp4); - df += temp2; - ddf += temp3; -/* L40: */ - } - f = *finit + *tau * fc; - erretm = (dabs(*finit) + dabs(*tau) * erretm) * 8.f + dabs(*tau) * df; - if (dabs(f) <= eps * erretm) { - goto L60; - } - if (f <= 0.f) { - lbd = *tau; - } else { - ubd = *tau; - } -/* L50: */ - } - *info = 1; -L60: - -/* Undo scaling */ - - if (scale) { - *tau *= sclinv; - } - return 0; - -/* End of SLAED6 */ - -} /* slaed6_ */ diff --git a/3rdparty/lapack/slaed7.c b/3rdparty/lapack/slaed7.c deleted file mode 100644 index 62539f4..0000000 --- a/3rdparty/lapack/slaed7.c +++ /dev/null @@ -1,352 +0,0 @@ -/* slaed7.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 real c_b10 = 1.f; -static real c_b11 = 0.f; -static integer c_n1 = -1; - -/* Subroutine */ int slaed7_(integer *icompq, integer *n, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, real *d__, real *q, - integer *ldq, integer *indxq, real *rho, integer *cutpnt, real * - qstore, integer *qptr, integer *prmptr, integer *perm, integer * - givptr, integer *givcol, real *givnum, real *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, indxc; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - integer indxp; - extern /* Subroutine */ int slaed8_(integer *, integer *, integer *, - integer *, real *, real *, integer *, integer *, real *, integer * -, real *, real *, real *, integer *, real *, integer *, integer *, - integer *, real *, integer *, integer *, integer *), slaed9_( - integer *, integer *, integer *, integer *, real *, real *, - integer *, real *, real *, real *, real *, integer *, integer *), - slaeda_(integer *, integer *, integer *, integer *, integer *, - integer *, integer *, integer *, real *, real *, integer *, real * -, real *, integer *); - integer idlmda; - extern /* Subroutine */ int xerbla_(char *, integer *), slamrg_( - integer *, integer *, real *, integer *, integer *, 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 */ -/* ======= */ - -/* SLAED7 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. SLAED1 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 SLAED8. */ - -/* The second stage consists of calculating the updated */ -/* eigenvalues. This is done by finding the roots of the secular */ -/* equation via the routine SLAED4 (as called by SLAED9). */ -/* 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) REAL array, dimension (N) */ -/* On entry, the eigenvalues of the rank-1-perturbed matrix. */ -/* On exit, the eigenvalues of the repaired matrix. */ - -/* Q (input/output) REAL 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) REAL */ -/* 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) REAL 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) REAL array, dimension (2, N lg N) */ -/* Each number indicates the S value to be used in the */ -/* corresponding Givens rotation. */ - -/* WORK (workspace) REAL 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_("SLAED7", &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 SLAED8 and SLAED9. */ - - 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; - slaeda_(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. */ - - slaed8_(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) { - slaed9_(&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) { - sgemm_("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; - slamrg_(&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 SLAED7 */ - -} /* slaed7_ */ diff --git a/3rdparty/lapack/slaed8.c b/3rdparty/lapack/slaed8.c deleted file mode 100644 index fb6a4cf..0000000 --- a/3rdparty/lapack/slaed8.c +++ /dev/null @@ -1,475 +0,0 @@ -/* slaed8.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 real c_b3 = -1.f; -static integer c__1 = 1; - -/* Subroutine */ int slaed8_(integer *icompq, integer *k, integer *n, integer - *qsiz, real *d__, real *q, integer *ldq, integer *indxq, real *rho, - integer *cutpnt, real *z__, real *dlamda, real *q2, integer *ldq2, - real *w, integer *perm, integer *givptr, integer *givcol, real * - givnum, integer *indxp, integer *indx, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real c__; - integer i__, j; - real s, t; - integer k2, n1, n2, jp, n1p1; - real eps, tau, tol; - integer jlam, imax, jmax; - extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, - integer *, real *, real *), sscal_(integer *, real *, real *, - integer *), scopy_(integer *, real *, integer *, real *, integer * -); - extern doublereal slapy2_(real *, real *), slamch_(char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer isamax_(integer *, real *, integer *); - extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer - *, integer *, integer *), slacpy_(char *, integer *, integer *, - real *, integer *, real *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAED8 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) REAL 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) REAL 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) REAL */ -/* 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 */ -/* SLAED3. */ - -/* CUTPNT (input) INTEGER */ -/* The location of the last eigenvalue in the leading */ -/* sub-matrix. min(1,N) <= CUTPNT <= N. */ - -/* Z (input) REAL 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) REAL array, dimension (N) */ -/* A copy of the first K eigenvalues which will be used by */ -/* SLAED3 to form the secular equation. */ - -/* Q2 (output) REAL array, dimension (LDQ2,N) */ -/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */ -/* a copy of the first K eigenvectors which will be used by */ -/* SLAED7 in a matrix multiply (SGEMM) to update the new */ -/* eigenvectors. */ - -/* LDQ2 (input) INTEGER */ -/* The leading dimension of the array Q2. LDQ2 >= max(1,N). */ - -/* W (output) REAL array, dimension (N) */ -/* The first k values of the final deflation-altered z-vector and */ -/* will be passed to SLAED3. */ - -/* 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) REAL 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_("SLAED8", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - n1 = *cutpnt; - n2 = *n - n1; - n1p1 = n1 + 1; - - if (*rho < 0.f) { - sscal_(&n2, &c_b3, &z__[n1p1], &c__1); - } - -/* Normalize z so that norm(z) = 1 */ - - t = 1.f / sqrt(2.f); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - indx[j] = j; -/* L10: */ - } - sscal_(n, &t, &z__[1], &c__1); - *rho = (r__1 = *rho * 2.f, dabs(r__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; - slamrg_(&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 = isamax_(n, &z__[1], &c__1); - jmax = isamax_(n, &d__[1], &c__1); - eps = slamch_("Epsilon"); - tol = eps * 8.f * (r__1 = d__[jmax], dabs(r__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 * (r__1 = z__[imax], dabs(r__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]]; - scopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 - + 1], &c__1); -/* L60: */ - } - slacpy_("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 * (r__1 = z__[j], dabs(r__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 * (r__1 = z__[j], dabs(r__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 = slapy2_(&c__, &s); - t = d__[j] - d__[jlam]; - c__ /= tau; - s = -s / tau; - if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) { - -/* Deflation is possible. */ - - z__[j] = tau; - z__[jlam] = 0.f; - -/* 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) { - srot_(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]]; - scopy_(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; - scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); - } else { - i__1 = *n - *k; - scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); - i__1 = *n - *k; - slacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* - k + 1) * q_dim1 + 1], ldq); - } - } - - return 0; - -/* End of SLAED8 */ - -} /* slaed8_ */ diff --git a/3rdparty/lapack/slaed9.c b/3rdparty/lapack/slaed9.c deleted file mode 100644 index 9152734..0000000 --- a/3rdparty/lapack/slaed9.c +++ /dev/null @@ -1,272 +0,0 @@ -/* slaed9.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 slaed9_(integer *k, integer *kstart, integer *kstop, - integer *n, real *d__, real *q, integer *ldq, real *rho, real *dlamda, - real *w, real *s, integer *lds, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; - real r__1; - - /* Builtin functions */ - double sqrt(doublereal), r_sign(real *, real *); - - /* Local variables */ - integer i__, j; - real temp; - extern doublereal snrm2_(integer *, real *, integer *); - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), slaed4_(integer *, integer *, real *, real *, real *, - real *, real *, integer *); - extern doublereal slamc3_(real *, real *); - 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 */ -/* ======= */ - -/* SLAED9 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 SLAED4 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 */ -/* SLAED4. 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) REAL array, dimension (N) */ -/* D(I) contains the updated eigenvalues */ -/* for KSTART <= I <= KSTOP. */ - -/* Q (workspace) REAL array, dimension (LDQ,N) */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max( 1, N ). */ - -/* RHO (input) REAL */ -/* The value of the parameter in the rank one update equation. */ -/* RHO >= 0 required. */ - -/* DLAMDA (input) REAL 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) REAL array, dimension (K) */ -/* The first K elements of this array contain the components */ -/* of the deflation-adjusted updating vector. */ - -/* S (output) REAL 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_("SLAED9", &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__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; -/* L10: */ - } - - i__1 = *kstop; - for (j = *kstart; j <= i__1; ++j) { - slaed4_(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. */ - - scopy_(k, &w[1], &c__1, &s[s_offset], &c__1); - -/* Initialize W(I) = Q(I,I) */ - - i__1 = *ldq + 1; - scopy_(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__) { - r__1 = sqrt(-w[i__]); - w[i__] = r_sign(&r__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 = snrm2_(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 SLAED9 */ - -} /* slaed9_ */ diff --git a/3rdparty/lapack/slaeda.c b/3rdparty/lapack/slaeda.c deleted file mode 100644 index 24da1a5..0000000 --- a/3rdparty/lapack/slaeda.c +++ /dev/null @@ -1,283 +0,0 @@ -/* slaeda.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 real c_b24 = 1.f; -static real c_b26 = 0.f; - -/* Subroutine */ int slaeda_(integer *n, integer *tlvls, integer *curlvl, - integer *curpbm, integer *prmptr, integer *perm, integer *givptr, - integer *givcol, real *givnum, real *q, integer *qptr, real *z__, - real *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, curr; - extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, - integer *, real *, real *); - integer bsiz1, bsiz2, psiz1, psiz2, zptr1; - extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, - real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, 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 */ -/* ======= */ - -/* SLAEDA 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) REAL array, dimension (2, N lg N) */ -/* Each number indicates the S value to be used in the */ -/* corresponding Givens rotation. */ - -/* Q (input) REAL 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) REAL 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) REAL 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_("SLAEDA", &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((real) (qptr[curr + 1] - qptr[curr])) + .5f); - bsiz2 = (integer) (sqrt((real) (qptr[curr + 2] - qptr[curr + 1])) + .5f); - i__1 = mid - bsiz1 - 1; - for (k = 1; k <= i__1; ++k) { - z__[k] = 0.f; -/* L10: */ - } - scopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], & - c__1); - scopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1); - i__1 = *n; - for (k = mid + bsiz2; k <= i__1; ++k) { - z__[k] = 0.f; -/* 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__) { - srot_(&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__) { - srot_(&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((real) (qptr[curr + 1] - qptr[curr])) + .5f); - bsiz2 = (integer) (sqrt((real) (qptr[curr + 2] - qptr[curr + 1])) + - .5f); - if (bsiz1 > 0) { - sgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, & - ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1); - } - i__2 = psiz1 - bsiz1; - scopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); - if (bsiz2 > 0) { - sgemv_("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; - scopy_(&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 SLAEDA */ - -} /* slaeda_ */ diff --git a/3rdparty/lapack/slaev2.c b/3rdparty/lapack/slaev2.c deleted file mode 100644 index 8b698a7..0000000 --- a/3rdparty/lapack/slaev2.c +++ /dev/null @@ -1,188 +0,0 @@ -/* slaev2.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 slaev2_(real *a, real *b, real *c__, real *rt1, real * - rt2, real *cs1, real *sn1) -{ - /* System generated locals */ - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real ab, df, cs, ct, tb, sm, tn, rt, adf, acs; - integer sgn1, sgn2; - real acmn, acmx; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAEV2 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) REAL */ -/* The (1,1) element of the 2-by-2 matrix. */ - -/* B (input) REAL */ -/* The (1,2) element and the conjugate of the (2,1) element of */ -/* the 2-by-2 matrix. */ - -/* C (input) REAL */ -/* The (2,2) element of the 2-by-2 matrix. */ - -/* RT1 (output) REAL */ -/* The eigenvalue of larger absolute value. */ - -/* RT2 (output) REAL */ -/* The eigenvalue of smaller absolute value. */ - -/* CS1 (output) REAL */ -/* SN1 (output) REAL */ -/* 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 = dabs(df); - tb = *b + *b; - ab = dabs(tb); - if (dabs(*a) > dabs(*c__)) { - acmx = *a; - acmn = *c__; - } else { - acmx = *c__; - acmn = *a; - } - if (adf > ab) { -/* Computing 2nd power */ - r__1 = ab / adf; - rt = adf * sqrt(r__1 * r__1 + 1.f); - } else if (adf < ab) { -/* Computing 2nd power */ - r__1 = adf / ab; - rt = ab * sqrt(r__1 * r__1 + 1.f); - } else { - -/* Includes case AB=ADF=0 */ - - rt = ab * sqrt(2.f); - } - if (sm < 0.f) { - *rt1 = (sm - rt) * .5f; - 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.f) { - *rt1 = (sm + rt) * .5f; - 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 * .5f; - *rt2 = rt * -.5f; - sgn1 = 1; - } - -/* Compute the eigenvector */ - - if (df >= 0.f) { - cs = df + rt; - sgn2 = 1; - } else { - cs = df - rt; - sgn2 = -1; - } - acs = dabs(cs); - if (acs > ab) { - ct = -tb / cs; - *sn1 = 1.f / sqrt(ct * ct + 1.f); - *cs1 = ct * *sn1; - } else { - if (ab == 0.f) { - *cs1 = 1.f; - *sn1 = 0.f; - } else { - tn = -cs / tb; - *cs1 = 1.f / sqrt(tn * tn + 1.f); - *sn1 = tn * *cs1; - } - } - if (sgn1 == sgn2) { - tn = *cs1; - *cs1 = -(*sn1); - *sn1 = tn; - } - return 0; - -/* End of SLAEV2 */ - -} /* slaev2_ */ diff --git a/3rdparty/lapack/slagtf.c b/3rdparty/lapack/slagtf.c deleted file mode 100644 index 8b78a50..0000000 --- a/3rdparty/lapack/slagtf.c +++ /dev/null @@ -1,223 +0,0 @@ -/* slagtf.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 slagtf_(integer *n, real *a, real *lambda, real *b, real - *c__, real *tol, real *d__, integer *in, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Local variables */ - integer k; - real tl, eps, piv1, piv2, temp, mult, scale1, scale2; - extern doublereal slamch_(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 */ -/* ======= */ - -/* SLAGTF 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 SLAGTF may */ -/* be used, in conjunction with SLAGTS, to obtain eigenvectors of T by */ -/* inverse iteration. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix T. */ - -/* A (input/output) REAL 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) REAL */ -/* On entry, the scalar lambda. */ - -/* B (input/output) REAL 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) REAL 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) REAL */ -/* 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) REAL 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_("SLAGTF", &i__1); - return 0; - } - - if (*n == 0) { - return 0; - } - - a[1] -= *lambda; - in[*n] = 0; - if (*n == 1) { - if (a[1] == 0.f) { - in[1] = 1; - } - return 0; - } - - eps = slamch_("Epsilon"); - - tl = dmax(*tol,eps); - scale1 = dabs(a[1]) + dabs(b[1]); - i__1 = *n - 1; - for (k = 1; k <= i__1; ++k) { - a[k + 1] -= *lambda; - scale2 = (r__1 = c__[k], dabs(r__1)) + (r__2 = a[k + 1], dabs(r__2)); - if (k < *n - 1) { - scale2 += (r__1 = b[k + 1], dabs(r__1)); - } - if (a[k] == 0.f) { - piv1 = 0.f; - } else { - piv1 = (r__1 = a[k], dabs(r__1)) / scale1; - } - if (c__[k] == 0.f) { - in[k] = 0; - piv2 = 0.f; - scale1 = scale2; - if (k < *n - 1) { - d__[k] = 0.f; - } - } else { - piv2 = (r__1 = c__[k], dabs(r__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.f; - } - } 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 (dmax(piv1,piv2) <= tl && in[*n] == 0) { - in[*n] = k; - } -/* L10: */ - } - if ((r__1 = a[*n], dabs(r__1)) <= scale1 * tl && in[*n] == 0) { - in[*n] = *n; - } - - return 0; - -/* End of SLAGTF */ - -} /* slagtf_ */ diff --git a/3rdparty/lapack/slagts.c b/3rdparty/lapack/slagts.c deleted file mode 100644 index 8ff7b64..0000000 --- a/3rdparty/lapack/slagts.c +++ /dev/null @@ -1,351 +0,0 @@ -/* slagts.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 slagts_(integer *job, integer *n, real *a, real *b, real - *c__, real *d__, integer *in, real *y, real *tol, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2, r__3, r__4, r__5; - - /* Builtin functions */ - double r_sign(real *, real *); - - /* Local variables */ - integer k; - real ak, eps, temp, pert, absak, sfmin; - extern doublereal slamch_(char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - real bignum; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAGTS 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 SLAGTF. 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 SLAGTS 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) REAL array, dimension (N) */ -/* On entry, A must contain the diagonal elements of U as */ -/* returned from SLAGTF. */ - -/* B (input) REAL array, dimension (N-1) */ -/* On entry, B must contain the first super-diagonal elements of */ -/* U as returned from SLAGTF. */ - -/* C (input) REAL array, dimension (N-1) */ -/* On entry, C must contain the sub-diagonal elements of L as */ -/* returned from SLAGTF. */ - -/* D (input) REAL array, dimension (N-2) */ -/* On entry, D must contain the second super-diagonal elements */ -/* of U as returned from SLAGTF. */ - -/* IN (input) INTEGER array, dimension (N) */ -/* On entry, IN must contain details of the matrix P as returned */ -/* from SLAGTF. */ - -/* Y (input/output) REAL array, dimension (N) */ -/* On entry, the right hand side vector y. */ -/* On exit, Y is overwritten by the solution vector x. */ - -/* TOL (input/output) REAL */ -/* 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_("SLAGTS", &i__1); - return 0; - } - - if (*n == 0) { - return 0; - } - - eps = slamch_("Epsilon"); - sfmin = slamch_("Safe minimum"); - bignum = 1.f / sfmin; - - if (*job < 0) { - if (*tol <= 0.f) { - *tol = dabs(a[1]); - if (*n > 1) { -/* Computing MAX */ - r__1 = *tol, r__2 = dabs(a[2]), r__1 = max(r__1,r__2), r__2 = - dabs(b[1]); - *tol = dmax(r__1,r__2); - } - i__1 = *n; - for (k = 3; k <= i__1; ++k) { -/* Computing MAX */ - r__4 = *tol, r__5 = (r__1 = a[k], dabs(r__1)), r__4 = max( - r__4,r__5), r__5 = (r__2 = b[k - 1], dabs(r__2)), - r__4 = max(r__4,r__5), r__5 = (r__3 = d__[k - 2], - dabs(r__3)); - *tol = dmax(r__4,r__5); -/* L10: */ - } - *tol *= eps; - if (*tol == 0.f) { - *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 = dabs(ak); - if (absak < 1.f) { - if (absak < sfmin) { - if (absak == 0.f || dabs(temp) * sfmin > absak) { - *info = k; - return 0; - } else { - temp *= bignum; - ak *= bignum; - } - } else if (dabs(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 = r_sign(tol, &ak); -L40: - absak = dabs(ak); - if (absak < 1.f) { - if (absak < sfmin) { - if (absak == 0.f || dabs(temp) * sfmin > absak) { - ak += pert; - pert *= 2; - goto L40; - } else { - temp *= bignum; - ak *= bignum; - } - } else if (dabs(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 = dabs(ak); - if (absak < 1.f) { - if (absak < sfmin) { - if (absak == 0.f || dabs(temp) * sfmin > absak) { - *info = k; - return 0; - } else { - temp *= bignum; - ak *= bignum; - } - } else if (dabs(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 = r_sign(tol, &ak); -L70: - absak = dabs(ak); - if (absak < 1.f) { - if (absak < sfmin) { - if (absak == 0.f || dabs(temp) * sfmin > absak) { - ak += pert; - pert *= 2; - goto L70; - } else { - temp *= bignum; - ak *= bignum; - } - } else if (dabs(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 SLAGTS */ - - return 0; -} /* slagts_ */ diff --git a/3rdparty/lapack/slaisnan.c b/3rdparty/lapack/slaisnan.c deleted file mode 100644 index 4c1f57c..0000000 --- a/3rdparty/lapack/slaisnan.c +++ /dev/null @@ -1,58 +0,0 @@ -/* slaisnan.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 slaisnan_(real *sin1, real *sin2) -{ - /* 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 SISNAN. */ - -/* SLAISNAN 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 */ -/* ========= */ - -/* SIN1 (input) REAL */ -/* SIN2 (input) REAL */ -/* Two numbers to compare for inequality. */ - -/* ===================================================================== */ - -/* .. Executable Statements .. */ - ret_val = *sin1 != *sin2; - return ret_val; -} /* slaisnan_ */ diff --git a/3rdparty/lapack/slals0.c b/3rdparty/lapack/slals0.c deleted file mode 100644 index 60378ce..0000000 --- a/3rdparty/lapack/slals0.c +++ /dev/null @@ -1,470 +0,0 @@ -/* slals0.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 real c_b5 = -1.f; -static integer c__1 = 1; -static real c_b11 = 1.f; -static real c_b13 = 0.f; -static integer c__0 = 0; - -/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx, - integer *ldbx, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real * - difl, real *difr, real *z__, integer *k, real *c__, real *s, real * - 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; - real r__1; - - /* Local variables */ - integer i__, j, m, n; - real dj; - integer nlp1; - real temp; - extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, - integer *, real *, real *); - extern doublereal snrm2_(integer *, real *, integer *); - real diflj, difrj, dsigj; - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), - sgemv_(char *, integer *, integer *, real *, real *, integer *, - real *, integer *, real *, real *, integer *), scopy_( - integer *, real *, integer *, real *, integer *); - extern doublereal slamc3_(real *, real *); - extern /* Subroutine */ int xerbla_(char *, integer *); - real dsigjp; - extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, - real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, - real *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLALS0 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL */ -/* 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) REAL */ -/* 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) REAL 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_("SLALS0", &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__) { - srot_(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. */ - - scopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - scopy_(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) { - scopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); - if (z__[1] < 0.f) { - sscal_(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.f || poles[j + (poles_dim1 << 1)] == 0.f) { - work[j] = 0.f; - } 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.f || poles[i__ + (poles_dim1 << 1)] == - 0.f) { - work[i__] = 0.f; - } else { - work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] - / (slamc3_(&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.f || poles[i__ + (poles_dim1 << 1)] == - 0.f) { - work[i__] = 0.f; - } else { - work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] - / (slamc3_(&poles[i__ + (poles_dim1 << 1)], & - dsigjp) + difrj) / (poles[i__ + (poles_dim1 << - 1)] + dj); - } -/* L40: */ - } - work[1] = -1.f; - temp = snrm2_(k, &work[1], &c__1); - sgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], & - c__1, &c_b13, &b[j + b_dim1], ldb); - slascl_("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; - slacpy_("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) { - scopy_(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.f) { - work[j] = 0.f; - } 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.f) { - work[i__] = 0.f; - } else { - r__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; - work[i__] = z__[j] / (slamc3_(&dsigj, &r__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.f) { - work[i__] = 0.f; - } else { - r__1 = -poles[i__ + (poles_dim1 << 1)]; - work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[ - i__]) / (dsigj + poles[i__ + poles_dim1]) / - difr[i__ + (difr_dim1 << 1)]; - } -/* L70: */ - } - sgemv_("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) { - scopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); - srot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, - s); - } - if (*k < max(m,n)) { - i__1 = n - *k; - slacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + - bx_dim1], ldbx); - } - -/* Step (3R): permute rows of B. */ - - scopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); - if (*sqre == 1) { - scopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); - } - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - scopy_(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__) { - r__1 = -givnum[i__ + givnum_dim1]; - srot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & - b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + - (givnum_dim1 << 1)], &r__1); -/* L100: */ - } - } - - return 0; - -/* End of SLALS0 */ - -} /* slals0_ */ diff --git a/3rdparty/lapack/slalsa.c b/3rdparty/lapack/slalsa.c deleted file mode 100644 index 6d102c5..0000000 --- a/3rdparty/lapack/slalsa.c +++ /dev/null @@ -1,454 +0,0 @@ -/* slalsa.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 real c_b7 = 1.f; -static real c_b8 = 0.f; -static integer c__2 = 2; - -/* Subroutine */ int slalsa_(integer *icompq, integer *smlsiz, integer *n, - integer *nrhs, real *b, integer *ldb, real *bx, integer *ldbx, real * - u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real * - z__, real *poles, integer *givptr, integer *givcol, integer *ldgcol, - integer *perm, real *givnum, real *c__, real *s, real *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, inode, ndiml; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - integer ndimr; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), slals0_(integer *, integer *, integer *, integer *, - integer *, real *, integer *, real *, integer *, integer *, - integer *, integer *, integer *, real *, integer *, real *, real * -, real *, real *, integer *, real *, real *, real *, integer *), - xerbla_(char *, integer *), slasdt_(integer *, integer *, - 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 */ -/* ======= */ - -/* SLALSA 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, SLALSA applies the inverse of the left singular vector */ -/* matrix of an upper bidiagonal matrix to the right hand side; and if */ -/* ICOMPQ = 1, SLALSA applies the right singular vector matrix to the */ -/* right hand side. The singular vector matrices were generated in */ -/* compact form by SLALSA. */ - -/* 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL array, dimension ( LDU, NLVL ). */ -/* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */ - -/* DIFR (input) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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_("SLALSA", &i__1); - return 0; - } - -/* Book-keeping and setting up the computation tree. */ - - inode = 1; - ndiml = inode + *n; - ndimr = ndiml + *n; - - slasdt_(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 SLASDQ. 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; - sgemm_("T", "N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf - + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); - sgemm_("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]; - scopy_(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; - slals0_(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; - slals0_(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 SLASDQ. 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; - sgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, & - b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); - sgemm_("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 SLALSA */ - -} /* slalsa_ */ diff --git a/3rdparty/lapack/slalsd.c b/3rdparty/lapack/slalsd.c deleted file mode 100644 index 22dc5d7..0000000 --- a/3rdparty/lapack/slalsd.c +++ /dev/null @@ -1,523 +0,0 @@ -/* slalsd.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 real c_b6 = 0.f; -static integer c__0 = 0; -static real c_b11 = 1.f; - -/* Subroutine */ int slalsd_(char *uplo, integer *smlsiz, integer *n, integer - *nrhs, real *d__, real *e, real *b, integer *ldb, real *rcond, - integer *rank, real *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1, i__2; - real r__1; - - /* Builtin functions */ - double log(doublereal), r_sign(real *, real *); - - /* Local variables */ - integer c__, i__, j, k; - real r__; - integer s, u, z__; - real cs; - integer bx; - real sn; - integer st, vt, nm1, st1; - real eps; - integer iwk; - real tol; - integer difl, difr; - real rcnd; - integer perm, nsub, nlvl, sqre, bxst; - extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, - integer *, real *, real *), sgemm_(char *, char *, integer *, - integer *, integer *, real *, real *, integer *, real *, integer * -, real *, real *, integer *); - integer poles, sizei, nsize; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - integer nwork, icmpq1, icmpq2; - extern doublereal slamch_(char *); - extern /* Subroutine */ int slasda_(integer *, integer *, integer *, - integer *, real *, real *, real *, integer *, real *, integer *, - real *, real *, real *, real *, integer *, integer *, integer *, - integer *, real *, real *, real *, real *, integer *, integer *), - xerbla_(char *, integer *), slalsa_(integer *, integer *, - integer *, integer *, real *, integer *, real *, integer *, real * -, integer *, real *, integer *, real *, real *, real *, real *, - integer *, integer *, integer *, integer *, real *, real *, real * -, real *, integer *, integer *), slascl_(char *, integer *, - integer *, real *, real *, integer *, integer *, real *, integer * -, integer *); - integer givcol; - extern integer isamax_(integer *, real *, integer *); - extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer - *, integer *, integer *, real *, real *, real *, integer *, real * -, integer *, real *, integer *, real *, integer *), - slacpy_(char *, integer *, integer *, real *, integer *, real *, - integer *), slartg_(real *, real *, real *, real *, real * -), slaset_(char *, integer *, integer *, real *, real *, real *, - integer *); - real orgnrm; - integer givnum; - extern doublereal slanst_(char *, integer *, real *, real *); - extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); - integer givptr, smlszp; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLALSD 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) REAL 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) REAL array, dimension (N-1) */ -/* Contains the super-diagonal entries of the bidiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* B (input/output) REAL 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) REAL */ -/* 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) REAL 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_("SLALSD", &i__1); - return 0; - } - - eps = slamch_("Epsilon"); - -/* Set up the tolerance. */ - - if (*rcond <= 0.f || *rcond >= 1.f) { - rcnd = eps; - } else { - rcnd = *rcond; - } - - *rank = 0; - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } else if (*n == 1) { - if (d__[1] == 0.f) { - slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); - } else { - *rank = 1; - slascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ - b_offset], ldb, info); - d__[1] = dabs(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__) { - slartg_(&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) { - srot_(&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]; - srot_(&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 = slanst_("M", n, &d__[1], &e[1]); - if (orgnrm == 0.f) { - slaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); - return 0; - } - - slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info); - slascl_("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; - slaset_("A", n, n, &c_b6, &c_b11, &work[1], n); - slasdq_("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 * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1)); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] <= tol) { - slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb); - } else { - slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ - i__ + b_dim1], ldb, info); - ++(*rank); - } -/* L40: */ - } - sgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & - c_b6, &work[nwork], n); - slacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb); - -/* Unscale. */ - - slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, - info); - slasrt_("D", n, &d__[1], info); - slascl_("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((real) (*n) / (real) (*smlsiz + 1)) / log(2.f)) + 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 ((r__1 = d__[i__], dabs(r__1)) < eps) { - d__[i__] = r_sign(&eps, &d__[i__]); - } -/* L50: */ - } - - i__1 = nm1; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((r__1 = e[i__], dabs(r__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 ((r__1 = e[i__], dabs(r__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; - scopy_(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. */ - - scopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); - } else if (nsize <= *smlsiz) { - -/* This is a small subproblem and is solved by SLASDQ. */ - - slaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], - n); - slasdq_("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; - } - slacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + - st1], n); - } else { - -/* A large problem. Solve it using divide and conquer. */ - - slasda_(&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; - slalsa_(&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 * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__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 ((r__1 = d__[i__], dabs(r__1)) <= tol) { - slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n); - } else { - ++(*rank); - slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ - bx + i__ - 1], n, info); - } - d__[i__] = (r__1 = d__[i__], dabs(r__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) { - scopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); - } else if (nsize <= *smlsiz) { - sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, - &work[bxst], n, &c_b6, &b[st + b_dim1], ldb); - } else { - slalsa_(&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. */ - - slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info); - slasrt_("D", n, &d__[1], info); - slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, - info); - - return 0; - -/* End of SLALSD */ - -} /* slalsd_ */ diff --git a/3rdparty/lapack/slamch_custom.c b/3rdparty/lapack/slamch_custom.c deleted file mode 100644 index b0e073e..0000000 --- a/3rdparty/lapack/slamch_custom.c +++ /dev/null @@ -1,88 +0,0 @@ -#include "clapack.h" -#include -#include - -/* *********************************************************************** */ - -doublereal slamc3_(real *a, real *b) -{ - /* System generated locals */ - real ret_val; - - - /* -- LAPACK auxiliary routine (version 3.1) -- */ - /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ - /* November 2006 */ - - /* .. Scalar Arguments .. */ - /* .. */ - - /* Purpose */ - /* ======= */ - - /* SLAMC3 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) REAL */ - /* B (input) REAL */ - /* The values A and B. */ - - /* ===================================================================== */ - - /* .. Executable Statements .. */ - - ret_val = *a + *b; - - return ret_val; - - /* End of SLAMC3 */ - -} /* slamc3_ */ - - -const unsigned char lapack_toupper_tab[] = -{ - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, - 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, - 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, - 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, - 90, 91, 92, 93, 94, 95, 96, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, - 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 123, 124, 125, 126, 127, 128, 129, 130, 131, - 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, - 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, - 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, - 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, - 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, - 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, - 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 -}; - -/* 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 FLT_DIGITS -#define FLT_DIGITS 24 -#endif - -const unsigned char lapack_lamch_tab[] = -{ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 2, 0, 0, 0, 0, 0, 0, 3, 4, 5, 6, 7, 0, 8, 9, 0, 10, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 2, 0, 0, 0, 0, 0, 0, 3, 4, 5, 6, 7, 0, 8, 9, - 0, 10, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 -}; - -const doublereal lapack_slamch_tab[] = -{ - 0, FLT_RADIX, FLT_EPSILON, FLT_MAX_EXP, FLT_MIN_EXP, FLT_DIGITS, FLT_MAX, - FLT_EPSILON*FLT_RADIX, 1, FLT_MIN*(1 + FLT_EPSILON), FLT_MIN -}; diff --git a/3rdparty/lapack/slamrg.c b/3rdparty/lapack/slamrg.c deleted file mode 100644 index 57601f6..0000000 --- a/3rdparty/lapack/slamrg.c +++ /dev/null @@ -1,131 +0,0 @@ -/* slamrg.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 slamrg_(integer *n1, integer *n2, real *a, integer * - strd1, integer *strd2, 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 */ -/* ======= */ - -/* SLAMRG 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) REAL 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. */ - -/* STRD1 (input) INTEGER */ -/* STRD2 (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 (STRDx = 1) or descending */ -/* (STRDx = -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 (*strd1 > 0) { - ind1 = 1; - } else { - ind1 = *n1; - } - if (*strd2 > 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 += *strd1; - --n1sv; - } else { - index[i__] = ind2; - ++i__; - ind2 += *strd2; - --n2sv; - } - goto L10; - } -/* end while */ - if (n1sv == 0) { - i__1 = n2sv; - for (n1sv = 1; n1sv <= i__1; ++n1sv) { - index[i__] = ind2; - ++i__; - ind2 += *strd2; -/* L20: */ - } - } else { -/* N2SV .EQ. 0 */ - i__1 = n1sv; - for (n2sv = 1; n2sv <= i__1; ++n2sv) { - index[i__] = ind1; - ++i__; - ind1 += *strd1; -/* L30: */ - } - } - - return 0; - -/* End of SLAMRG */ - -} /* slamrg_ */ diff --git a/3rdparty/lapack/slaneg.c b/3rdparty/lapack/slaneg.c deleted file mode 100644 index beff686..0000000 --- a/3rdparty/lapack/slaneg.c +++ /dev/null @@ -1,218 +0,0 @@ -/* slaneg.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 slaneg_(integer *n, real *d__, real *lld, real *sigma, real *pivmin, - integer *r__) -{ - /* System generated locals */ - integer ret_val, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer j; - real p, t; - integer bj; - real tmp; - integer neg1, neg2; - real bsav, gamma, dplus; - integer negcnt; - logical sawnan; - extern logical sisnan_(real *); - real dminus; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLANEG 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 SLARRB. */ - -/* 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) REAL array, dimension (N) */ -/* The N diagonal elements of the diagonal matrix D. */ - -/* LLD (input) REAL array, dimension (N-1) */ -/* The (N-1) elements L(i)*L(i)*D(i). */ - -/* SIGMA (input) REAL */ -/* Shift amount in T - sigma I = L D L^T. */ - -/* PIVMIN (input) REAL */ -/* 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.f) { - ++neg1; - } - tmp = t / dplus; - t = tmp * lld[j] - *sigma; -/* L21: */ - } - sawnan = sisnan_(&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.f) { - ++neg1; - } - tmp = t / dplus; - if (sisnan_(&tmp)) { - tmp = 1.f; - } - 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.f) { - ++neg2; - } - tmp = p / dminus; - p = tmp * d__[j] - *sigma; -/* L23: */ - } - sawnan = sisnan_(&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.f) { - ++neg2; - } - tmp = p / dminus; - if (sisnan_(&tmp)) { - tmp = 1.f; - } - 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.f) { - ++negcnt; - } - ret_val = negcnt; - return ret_val; -} /* slaneg_ */ diff --git a/3rdparty/lapack/slange.c b/3rdparty/lapack/slange.c deleted file mode 100644 index bcce944..0000000 --- a/3rdparty/lapack/slange.c +++ /dev/null @@ -1,199 +0,0 @@ -/* slange.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 slange_(char *norm, integer *m, integer *n, real *a, integer *lda, - real *work) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - real ret_val, r__1, r__2, r__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j; - real sum, scale; - extern logical lsame_(char *, char *); - real value; - extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, - real *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLANGE 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 */ -/* =========== */ - -/* SLANGE returns the value */ - -/* SLANGE = ( 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 SLANGE as described */ -/* above. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. When M = 0, */ -/* SLANGE is set to zero. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. N >= 0. When N = 0, */ -/* SLANGE is set to zero. */ - -/* A (input) REAL 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) REAL 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.f; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.f; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); - value = dmax(r__2,r__3); -/* L10: */ - } -/* L20: */ - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.f; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.f; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); -/* L30: */ - } - value = dmax(value,sum); -/* L40: */ - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.f; -/* L50: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); -/* L60: */ - } -/* L70: */ - } - value = 0.f; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - r__1 = value, r__2 = work[i__]; - value = dmax(r__1,r__2); -/* L80: */ - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.f; - sum = 1.f; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); -/* L90: */ - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of SLANGE */ - -} /* slange_ */ diff --git a/3rdparty/lapack/slanst.c b/3rdparty/lapack/slanst.c deleted file mode 100644 index 54bef0c..0000000 --- a/3rdparty/lapack/slanst.c +++ /dev/null @@ -1,166 +0,0 @@ -/* slanst.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 slanst_(char *norm, integer *n, real *d__, real *e) -{ - /* System generated locals */ - integer i__1; - real ret_val, r__1, r__2, r__3, r__4, r__5; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__; - real sum, scale; - extern logical lsame_(char *, char *); - real anorm; - extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, - real *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLANST 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 */ -/* =========== */ - -/* SLANST returns the value */ - -/* SLANST = ( 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 SLANST as described */ -/* above. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, SLANST is */ -/* set to zero. */ - -/* D (input) REAL array, dimension (N) */ -/* The diagonal elements of A. */ - -/* E (input) REAL 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.f; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - anorm = (r__1 = d__[*n], dabs(r__1)); - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1)); - anorm = dmax(r__2,r__3); -/* Computing MAX */ - r__2 = anorm, r__3 = (r__1 = e[i__], dabs(r__1)); - anorm = dmax(r__2,r__3); -/* L10: */ - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1' || lsame_(norm, "I")) { - -/* Find norm1(A). */ - - if (*n == 1) { - anorm = dabs(d__[1]); - } else { -/* Computing MAX */ - r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = e[*n - 1], dabs( - r__1)) + (r__2 = d__[*n], dabs(r__2)); - anorm = dmax(r__3,r__4); - i__1 = *n - 1; - for (i__ = 2; i__ <= i__1; ++i__) { -/* Computing MAX */ - r__4 = anorm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 = - e[i__], dabs(r__2)) + (r__3 = e[i__ - 1], dabs(r__3)); - anorm = dmax(r__4,r__5); -/* L20: */ - } - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.f; - sum = 1.f; - if (*n > 1) { - i__1 = *n - 1; - slassq_(&i__1, &e[1], &c__1, &scale, &sum); - sum *= 2; - } - slassq_(n, &d__[1], &c__1, &scale, &sum); - anorm = scale * sqrt(sum); - } - - ret_val = anorm; - return ret_val; - -/* End of SLANST */ - -} /* slanst_ */ diff --git a/3rdparty/lapack/slansy.c b/3rdparty/lapack/slansy.c deleted file mode 100644 index 9dd684e..0000000 --- a/3rdparty/lapack/slansy.c +++ /dev/null @@ -1,239 +0,0 @@ -/* slansy.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 slansy_(char *norm, char *uplo, integer *n, real *a, integer *lda, - real *work) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - real ret_val, r__1, r__2, r__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j; - real sum, absa, scale; - extern logical lsame_(char *, char *); - real value; - extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, - real *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLANSY 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 */ -/* =========== */ - -/* SLANSY returns the value */ - -/* SLANSY = ( 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 SLANSY 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, SLANSY is */ -/* set to zero. */ - -/* A (input) REAL 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) REAL 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.f; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.f; - 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 */ - r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs( - r__1)); - value = dmax(r__2,r__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 */ - r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs( - r__1)); - value = dmax(r__2,r__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.f; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.f; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - absa = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); - sum += absa; - work[i__] += absa; -/* L50: */ - } - work[j] = sum + (r__1 = a[j + j * a_dim1], dabs(r__1)); -/* L60: */ - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - r__1 = value, r__2 = work[i__]; - value = dmax(r__1,r__2); -/* L70: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.f; -/* L80: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = work[j] + (r__1 = a[j + j * a_dim1], dabs(r__1)); - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - absa = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); - sum += absa; - work[i__] += absa; -/* L90: */ - } - value = dmax(value,sum); -/* L100: */ - } - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.f; - sum = 1.f; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - i__2 = j - 1; - slassq_(&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; - slassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); -/* L120: */ - } - } - sum *= 2; - i__1 = *lda + 1; - slassq_(n, &a[a_offset], &i__1, &scale, &sum); - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of SLANSY */ - -} /* slansy_ */ diff --git a/3rdparty/lapack/slapy2.c b/3rdparty/lapack/slapy2.c deleted file mode 100644 index 13eb5d9..0000000 --- a/3rdparty/lapack/slapy2.c +++ /dev/null @@ -1,73 +0,0 @@ -/* slapy2.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 slapy2_(real *x, real *y) -{ - /* System generated locals */ - real ret_val, r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real 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 */ -/* ======= */ - -/* SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary */ -/* overflow. */ - -/* Arguments */ -/* ========= */ - -/* X (input) REAL */ -/* Y (input) REAL */ -/* X and Y specify the values x and y. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - xabs = dabs(*x); - yabs = dabs(*y); - w = dmax(xabs,yabs); - z__ = dmin(xabs,yabs); - if (z__ == 0.f) { - ret_val = w; - } else { -/* Computing 2nd power */ - r__1 = z__ / w; - ret_val = w * sqrt(r__1 * r__1 + 1.f); - } - return ret_val; - -/* End of SLAPY2 */ - -} /* slapy2_ */ diff --git a/3rdparty/lapack/slar1v.c b/3rdparty/lapack/slar1v.c deleted file mode 100644 index b6e8d76..0000000 --- a/3rdparty/lapack/slar1v.c +++ /dev/null @@ -1,440 +0,0 @@ -/* slar1v.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 slar1v_(integer *n, integer *b1, integer *bn, real * - lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real * - gaptol, real *z__, logical *wantnc, integer *negcnt, real *ztz, real * - mingma, integer *r__, integer *isuppz, real *nrminv, real *resid, - real *rqcorr, real *work) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2, r__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__; - real s; - integer r1, r2; - real eps, tmp; - integer neg1, neg2, indp, inds; - real dplus; - extern doublereal slamch_(char *); - integer indlpl, indumn; - extern logical sisnan_(real *); - real 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 */ -/* ======= */ - -/* SLAR1V 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) REAL */ -/* 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) REAL array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */ -/* L, in elements 1 to N-1. */ - -/* D (input) REAL array, dimension (N) */ -/* The n diagonal elements of the diagonal matrix D. */ - -/* LD (input) REAL array, dimension (N-1) */ -/* The n-1 elements L(i)*D(i). */ - -/* LLD (input) REAL array, dimension (N-1) */ -/* The n-1 elements L(i)*L(i)*D(i). */ - -/* PIVMIN (input) REAL */ -/* The minimum pivot in the Sturm sequence. */ - -/* GAPTOL (input) REAL */ -/* Tolerance that indicates when eigenvector entries are negligible */ -/* w.r.t. their contribution to the residual. */ - -/* Z (input/output) REAL 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) REAL */ -/* The square of the 2-norm of Z. */ - -/* MINGMA (output) REAL */ -/* 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) REAL */ -/* NRMINV = 1/SQRT( ZTZ ) */ - -/* RESID (output) REAL */ -/* The residual of the FP vector. */ -/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */ - -/* RQCORR (output) REAL */ -/* The Rayleigh Quotient correction to LAMBDA. */ -/* RQCORR = MINGMA*TMP */ - -/* WORK (workspace) REAL 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 = slamch_("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.f; - } 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.f) { - ++neg1; - } - work[inds + i__] = s * work[indlpl + i__] * l[i__]; - s = work[inds + i__] - *lambda; -/* L50: */ - } - sawnan1 = sisnan_(&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 = sisnan_(&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 (dabs(dplus) < *pivmin) { - dplus = -(*pivmin); - } - work[indlpl + i__] = ld[i__] / dplus; - if (dplus < 0.f) { - ++neg1; - } - work[inds + i__] = s * work[indlpl + i__] * l[i__]; - if (work[indlpl + i__] == 0.f) { - 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 (dabs(dplus) < *pivmin) { - dplus = -(*pivmin); - } - work[indlpl + i__] = ld[i__] / dplus; - work[inds + i__] = s * work[indlpl + i__] * l[i__]; - if (work[indlpl + i__] == 0.f) { - 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.f) { - ++neg2; - } - work[indumn + i__] = l[i__] * tmp; - work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; -/* L80: */ - } - tmp = work[indp + r1 - 1]; - sawnan2 = sisnan_(&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 (dabs(dminus) < *pivmin) { - dminus = -(*pivmin); - } - tmp = d__[i__] / dminus; - if (dminus < 0.f) { - ++neg2; - } - work[indumn + i__] = l[i__] * tmp; - work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; - if (tmp == 0.f) { - 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.f) { - ++neg1; - } - if (*wantnc) { - *negcnt = neg1 + neg2; - } else { - *negcnt = -1; - } - if (dabs(*mingma) == 0.f) { - *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.f) { - tmp = eps * work[inds + i__]; - } - if (dabs(tmp) <= dabs(*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.f; - *ztz = 1.f; - -/* 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 (((r__1 = z__[i__], dabs(r__1)) + (r__2 = z__[i__ + 1], dabs( - r__2))) * (r__3 = ld[i__], dabs(r__3)) < *gaptol) { - z__[i__] = 0.f; - 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.f) { - z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2]; - } else { - z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]); - } - if (((r__1 = z__[i__], dabs(r__1)) + (r__2 = z__[i__ + 1], dabs( - r__2))) * (r__3 = ld[i__], dabs(r__3)) < *gaptol) { - z__[i__] = 0.f; - 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 (((r__1 = z__[i__], dabs(r__1)) + (r__2 = z__[i__ + 1], dabs( - r__2))) * (r__3 = ld[i__], dabs(r__3)) < *gaptol) { - z__[i__ + 1] = 0.f; - 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.f) { - z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1]; - } else { - z__[i__ + 1] = -(work[indumn + i__] * z__[i__]); - } - if (((r__1 = z__[i__], dabs(r__1)) + (r__2 = z__[i__ + 1], dabs( - r__2))) * (r__3 = ld[i__], dabs(r__3)) < *gaptol) { - z__[i__ + 1] = 0.f; - isuppz[2] = i__; - goto L280; - } - *ztz += z__[i__ + 1] * z__[i__ + 1]; -/* L270: */ - } -L280: - ; - } - -/* Compute quantities for convergence test */ - - tmp = 1.f / *ztz; - *nrminv = sqrt(tmp); - *resid = dabs(*mingma) * *nrminv; - *rqcorr = *mingma * tmp; - - - return 0; - -/* End of SLAR1V */ - -} /* slar1v_ */ diff --git a/3rdparty/lapack/slarf.c b/3rdparty/lapack/slarf.c deleted file mode 100644 index 110b33a..0000000 --- a/3rdparty/lapack/slarf.c +++ /dev/null @@ -1,191 +0,0 @@ -/* slarf.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 real c_b4 = 1.f; -static real c_b5 = 0.f; -static integer c__1 = 1; - -/* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v, - integer *incv, real *tau, real *c__, integer *ldc, real *work) -{ - /* System generated locals */ - integer c_dim1, c_offset; - real r__1; - - /* Local variables */ - integer i__; - logical applyleft; - extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, - integer *, real *, integer *, real *, integer *); - extern logical lsame_(char *, char *); - integer lastc; - extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, - real *, integer *, real *, integer *, real *, real *, integer *); - integer lastv; - extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_( - integer *, integer *, real *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLARF 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) REAL 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) REAL */ -/* The value tau in the representation of H. */ - -/* C (input/output) REAL 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) REAL 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.f) { -/* 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.f) { - --lastv; - i__ -= *incv; - } - if (applyleft) { -/* Scan for the last non-zero column in C(1:lastv,:). */ - lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); - } else { -/* Scan for the last non-zero row in C(:,1:lastv). */ - lastc = ilaslr_(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) */ - - sgemv_("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)' */ - - r__1 = -(*tau); - sger_(&lastv, &lastc, &r__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) */ - - sgemv_("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)' */ - - r__1 = -(*tau); - sger_(&lastc, &lastv, &r__1, &work[1], &c__1, &v[1], incv, &c__[ - c_offset], ldc); - } - } - return 0; - -/* End of SLARF */ - -} /* slarf_ */ diff --git a/3rdparty/lapack/slarfb.c b/3rdparty/lapack/slarfb.c deleted file mode 100644 index 72d7285..0000000 --- a/3rdparty/lapack/slarfb.c +++ /dev/null @@ -1,773 +0,0 @@ -/* slarfb.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 real c_b14 = 1.f; -static real c_b25 = -1.f; - -/* Subroutine */ int slarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, real *v, integer *ldv, - real *t, integer *ldt, real *c__, integer *ldc, real *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 logical lsame_(char *, char *); - integer lastc; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - integer lastv; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), strmm_(char *, char *, char *, char *, integer *, - integer *, real *, real *, integer *, real *, integer *); - extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_( - integer *, integer *, real *, 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 */ -/* ======= */ - -/* SLARFB 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) REAL 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) REAL 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) REAL 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) REAL 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 = ilaslr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslc_(&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) { - scopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); -/* L10: */ - } - -/* W := W * V1 */ - - strmm_("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; - sgemm_("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 */ - - strmm_("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; - sgemm_("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' */ - - strmm_("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 = ilaslr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslr_(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) { - scopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L40: */ - } - -/* W := W * V1 */ - - strmm_("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; - sgemm_("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' */ - - strmm_("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; - sgemm_("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' */ - - strmm_("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 = ilaslr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslc_(&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) { - scopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); -/* L70: */ - } - -/* W := W * V2 */ - - strmm_("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; - sgemm_("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 */ - - strmm_("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; - sgemm_("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' */ - - strmm_("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 = ilaslr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslr_(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) { - scopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, & - work[j * work_dim1 + 1], &c__1); -/* L100: */ - } - -/* W := W * V2 */ - - strmm_("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; - sgemm_("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' */ - - strmm_("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; - sgemm_("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' */ - - strmm_("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 = ilaslc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslc_(&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) { - scopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); -/* L130: */ - } - -/* W := W * V1' */ - - strmm_("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; - sgemm_("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 */ - - strmm_("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; - sgemm_("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 */ - - strmm_("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 = ilaslc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslr_(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) { - scopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L160: */ - } - -/* W := W * V1' */ - - strmm_("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; - sgemm_("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' */ - - strmm_("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; - sgemm_("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 */ - - strmm_("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 = ilaslc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslc_(&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) { - scopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); -/* L190: */ - } - -/* W := W * V2' */ - - strmm_("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; - sgemm_("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 */ - - strmm_("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; - sgemm_("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 */ - - strmm_("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 = ilaslc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslr_(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) { - scopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, - &work[j * work_dim1 + 1], &c__1); -/* L220: */ - } - -/* W := W * V2' */ - - strmm_("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; - sgemm_("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' */ - - strmm_("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; - sgemm_("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 */ - - strmm_("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 SLARFB */ - -} /* slarfb_ */ diff --git a/3rdparty/lapack/slarfg.c b/3rdparty/lapack/slarfg.c deleted file mode 100644 index 7f75262..0000000 --- a/3rdparty/lapack/slarfg.c +++ /dev/null @@ -1,169 +0,0 @@ -/* slarfg.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 slarfg_(integer *n, real *alpha, real *x, integer *incx, - real *tau) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Builtin functions */ - double r_sign(real *, real *); - - /* Local variables */ - integer j, knt; - real beta; - extern doublereal snrm2_(integer *, real *, integer *); - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - real xnorm; - extern doublereal slapy2_(real *, real *), slamch_(char *); - real 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 */ -/* ======= */ - -/* SLARFG 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) REAL */ -/* On entry, the value alpha. */ -/* On exit, it is overwritten with the value beta. */ - -/* X (input/output) REAL 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) REAL */ -/* The value tau. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n <= 1) { - *tau = 0.f; - return 0; - } - - i__1 = *n - 1; - xnorm = snrm2_(&i__1, &x[1], incx); - - if (xnorm == 0.f) { - -/* H = I */ - - *tau = 0.f; - } else { - -/* general case */ - - r__1 = slapy2_(alpha, &xnorm); - beta = -r_sign(&r__1, alpha); - safmin = slamch_("S") / slamch_("E"); - knt = 0; - if (dabs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - - rsafmn = 1.f / safmin; -L10: - ++knt; - i__1 = *n - 1; - sscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - *alpha *= rsafmn; - if (dabs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = snrm2_(&i__1, &x[1], incx); - r__1 = slapy2_(alpha, &xnorm); - beta = -r_sign(&r__1, alpha); - } - *tau = (beta - *alpha) / beta; - i__1 = *n - 1; - r__1 = 1.f / (*alpha - beta); - sscal_(&i__1, &r__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 SLARFG */ - -} /* slarfg_ */ diff --git a/3rdparty/lapack/slarfp.c b/3rdparty/lapack/slarfp.c deleted file mode 100644 index bbe9d4f..0000000 --- a/3rdparty/lapack/slarfp.c +++ /dev/null @@ -1,191 +0,0 @@ -/* slarfp.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 slarfp_(integer *n, real *alpha, real *x, integer *incx, - real *tau) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Builtin functions */ - double r_sign(real *, real *); - - /* Local variables */ - integer j, knt; - real beta; - extern doublereal snrm2_(integer *, real *, integer *); - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - real xnorm; - extern doublereal slapy2_(real *, real *), slamch_(char *); - real 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 */ -/* ======= */ - -/* SLARFP 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) REAL */ -/* On entry, the value alpha. */ -/* On exit, it is overwritten with the value beta. */ - -/* X (input/output) REAL 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) REAL */ -/* The value tau. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n <= 0) { - *tau = 0.f; - return 0; - } - - i__1 = *n - 1; - xnorm = snrm2_(&i__1, &x[1], incx); - - if (xnorm == 0.f) { - -/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0. */ - - if (*alpha >= 0.f) { -/* 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.f; - } else { -/* However, the application routines rely on explicit */ -/* zero checks when TAU.ne.ZERO, and we must clear X. */ - *tau = 2.f; - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - x[(j - 1) * *incx + 1] = 0.f; - } - *alpha = -(*alpha); - } - } else { - -/* general case */ - - r__1 = slapy2_(alpha, &xnorm); - beta = r_sign(&r__1, alpha); - safmin = slamch_("S") / slamch_("E"); - knt = 0; - if (dabs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - - rsafmn = 1.f / safmin; -L10: - ++knt; - i__1 = *n - 1; - sscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - *alpha *= rsafmn; - if (dabs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = snrm2_(&i__1, &x[1], incx); - r__1 = slapy2_(alpha, &xnorm); - beta = r_sign(&r__1, alpha); - } - *alpha += beta; - if (beta < 0.f) { - beta = -beta; - *tau = -(*alpha) / beta; - } else { - *alpha = xnorm * (xnorm / *alpha); - *tau = *alpha / beta; - *alpha = -(*alpha); - } - i__1 = *n - 1; - r__1 = 1.f / *alpha; - sscal_(&i__1, &r__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 SLARFP */ - -} /* slarfp_ */ diff --git a/3rdparty/lapack/slarft.c b/3rdparty/lapack/slarft.c deleted file mode 100644 index dcbb6a7..0000000 --- a/3rdparty/lapack/slarft.c +++ /dev/null @@ -1,323 +0,0 @@ -/* slarft.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 real c_b8 = 0.f; - -/* Subroutine */ int slarft_(char *direct, char *storev, integer *n, integer * - k, real *v, integer *ldv, real *tau, real *t, integer *ldt) -{ - /* System generated locals */ - integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; - real r__1; - - /* Local variables */ - integer i__, j, prevlastv; - real vii; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, - real *, integer *, real *, integer *, real *, real *, integer *); - integer lastv; - extern /* Subroutine */ int strmv_(char *, char *, char *, integer *, - real *, integer *, real *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLARFT 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) REAL 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) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i). */ - -/* T (output) REAL 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.f) { - -/* H(i) = I */ - - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = 0.f; -/* L10: */ - } - } else { - -/* general case */ - - vii = v[i__ + i__ * v_dim1]; - v[i__ + i__ * v_dim1] = 1.f; - 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.f) { - 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; - r__1 = -tau[i__]; - sgemv_("Transpose", &i__2, &i__3, &r__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.f) { - 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; - r__1 = -tau[i__]; - sgemv_("No transpose", &i__2, &i__3, &r__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; - strmv_("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.f) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t[j + i__ * t_dim1] = 0.f; -/* 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.f; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[lastv + i__ * v_dim1] != 0.f) { - 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__; - r__1 = -tau[i__]; - sgemv_("Transpose", &i__1, &i__2, &r__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.f; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[i__ + lastv * v_dim1] != 0.f) { - 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; - r__1 = -tau[i__]; - sgemv_("No transpose", &i__1, &i__2, &r__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__; - strmv_("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 SLARFT */ - -} /* slarft_ */ diff --git a/3rdparty/lapack/slarnv.c b/3rdparty/lapack/slarnv.c deleted file mode 100644 index 3511089..0000000 --- a/3rdparty/lapack/slarnv.c +++ /dev/null @@ -1,146 +0,0 @@ -/* slarnv.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 slarnv_(integer *idist, integer *iseed, integer *n, real - *x) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - - /* Builtin functions */ - double log(doublereal), sqrt(doublereal), cos(doublereal); - - /* Local variables */ - integer i__; - real u[128]; - integer il, iv, il2; - extern /* Subroutine */ int slaruv_(integer *, integer *, real *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLARNV 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) REAL array, dimension (N) */ -/* The generated random numbers. */ - -/* Further Details */ -/* =============== */ - -/* This routine calls the auxiliary routine SLARUV 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 SLARUV to generate IL2 numbers from a uniform (0,1) */ -/* distribution (IL2 <= LV) */ - - slaruv_(&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.f - 1.f; -/* 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.f) * cos(u[ - (i__ << 1) - 1] * 6.2831853071795864769252867663f); -/* L30: */ - } - } -/* L40: */ - } - return 0; - -/* End of SLARNV */ - -} /* slarnv_ */ diff --git a/3rdparty/lapack/slarra.c b/3rdparty/lapack/slarra.c deleted file mode 100644 index e96f8aa..0000000 --- a/3rdparty/lapack/slarra.c +++ /dev/null @@ -1,155 +0,0 @@ -/* slarra.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 slarra_(integer *n, real *d__, real *e, real *e2, real * - spltol, real *tnrm, integer *nsplit, integer *isplit, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__; - real 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. */ -/* SLARRA sets any "small" off-diagonal elements to zero. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N > 0. */ - -/* D (input) REAL array, dimension (N) */ -/* On entry, the N diagonal elements of the tridiagonal */ -/* matrix T. */ - -/* E (input/output) REAL 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) REAL 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) REAL */ -/* 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) REAL */ -/* 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.f) { -/* Criterion based on absolute off-diagonal value */ - tmp1 = dabs(*spltol) * *tnrm; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - eabs = (r__1 = e[i__], dabs(r__1)); - if (eabs <= tmp1) { - e[i__] = 0.f; - e2[i__] = 0.f; - isplit[*nsplit] = i__; - ++(*nsplit); - } -/* L9: */ - } - } else { -/* Criterion that guarantees relative accuracy */ - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - eabs = (r__1 = e[i__], dabs(r__1)); - if (eabs <= *spltol * sqrt((r__1 = d__[i__], dabs(r__1))) * sqrt(( - r__2 = d__[i__ + 1], dabs(r__2)))) { - e[i__] = 0.f; - e2[i__] = 0.f; - isplit[*nsplit] = i__; - ++(*nsplit); - } -/* L10: */ - } - } - isplit[*nsplit] = *n; - return 0; - -/* End of SLARRA */ - -} /* slarra_ */ diff --git a/3rdparty/lapack/slarrb.c b/3rdparty/lapack/slarrb.c deleted file mode 100644 index e52e011..0000000 --- a/3rdparty/lapack/slarrb.c +++ /dev/null @@ -1,349 +0,0 @@ -/* slarrb.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 slarrb_(integer *n, real *d__, real *lld, integer * - ifirst, integer *ilast, real *rtol1, real *rtol2, integer *offset, - real *w, real *wgap, real *werr, real *work, integer *iwork, real * - pivmin, real *spdiam, integer *twist, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Builtin functions */ - double log(doublereal); - - /* Local variables */ - integer i__, k, r__, i1, ii, ip; - real gap, mid, tmp, back, lgap, rgap, left; - integer iter, nint, prev, next; - real cvrgd, right, width; - extern integer slaneg_(integer *, real *, real *, real *, real *, integer - *); - integer negcnt; - real 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, SLARRB */ -/* 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) REAL array, dimension (N) */ -/* The N diagonal elements of the diagonal matrix D. */ - -/* LLD (input) REAL 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) REAL */ -/* RTOL2 (input) REAL */ -/* 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) REAL 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) REAL 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) REAL 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) REAL 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.f)) + - 2; - mnwdth = *pivmin * 2.f; - - 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 = dmin(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 = slaneg_(n, &d__[1], &lld[1], &left, pivmin, &r__); - if (negcnt > i__ - 1) { - left -= back; - back *= 2.f; - 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 = slaneg_(n, &d__[1], &lld[1], &right, pivmin, &r__); - if (negcnt < i__) { - right += back; - back *= 2.f; - goto L50; - } - width = (r__1 = left - right, dabs(r__1)) * .5f; -/* Computing MAX */ - r__1 = dabs(left), r__2 = dabs(right); - tmp = dmax(r__1,r__2); -/* Computing MAX */ - r__1 = *rtol1 * gap, r__2 = *rtol2 * tmp; - cvrgd = dmax(r__1,r__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 = dmin(lgap,rgap); - next = iwork[k - 1]; - left = work[k - 1]; - right = work[k]; - mid = (left + right) * .5f; -/* semiwidth of interval */ - width = right - mid; -/* Computing MAX */ - r__1 = dabs(left), r__2 = dabs(right); - tmp = dmax(r__1,r__2); -/* Computing MAX */ - r__1 = *rtol1 * gap, r__2 = *rtol2 * tmp; - cvrgd = dmax(r__1,r__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 = slaneg_(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]) * .5f; - 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 */ - r__1 = 0.f, r__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1]; - wgap[ii - 1] = dmax(r__1,r__2); -/* L111: */ - } - return 0; - -/* End of SLARRB */ - -} /* slarrb_ */ diff --git a/3rdparty/lapack/slarrc.c b/3rdparty/lapack/slarrc.c deleted file mode 100644 index 11b173b..0000000 --- a/3rdparty/lapack/slarrc.c +++ /dev/null @@ -1,183 +0,0 @@ -/* slarrc.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 slarrc_(char *jobt, integer *n, real *vl, real *vu, real - *d__, real *e, real *pivmin, integer *eigcnt, integer *lcnt, integer * - rcnt, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Local variables */ - integer i__; - real sl, su, tmp, tmp2; - logical matt; - extern logical lsame_(char *, char *); - real 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.f) { - ++(*lcnt); - } - if (rpivot <= 0.f) { - ++(*rcnt); - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing 2nd power */ - r__1 = e[i__]; - tmp = r__1 * r__1; - lpivot = d__[i__ + 1] - *vl - tmp / lpivot; - rpivot = d__[i__ + 1] - *vu - tmp / rpivot; - if (lpivot <= 0.f) { - ++(*lcnt); - } - if (rpivot <= 0.f) { - ++(*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.f) { - ++(*lcnt); - } - if (rpivot <= 0.f) { - ++(*rcnt); - } - tmp = e[i__] * d__[i__] * e[i__]; - - tmp2 = tmp / lpivot; - if (tmp2 == 0.f) { - sl = tmp - *vl; - } else { - sl = sl * tmp2 - *vl; - } - - tmp2 = tmp / rpivot; - if (tmp2 == 0.f) { - su = tmp - *vu; - } else { - su = su * tmp2 - *vu; - } -/* L20: */ - } - lpivot = d__[*n] + sl; - rpivot = d__[*n] + su; - if (lpivot <= 0.f) { - ++(*lcnt); - } - if (rpivot <= 0.f) { - ++(*rcnt); - } - } - *eigcnt = *rcnt - *lcnt; - return 0; - -/* end of SLARRC */ - -} /* slarrc_ */ diff --git a/3rdparty/lapack/slarrd.c b/3rdparty/lapack/slarrd.c deleted file mode 100644 index 16d9421..0000000 --- a/3rdparty/lapack/slarrd.c +++ /dev/null @@ -1,790 +0,0 @@ -/* slarrd.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 slarrd_(char *range, char *order, integer *n, real *vl, - real *vu, integer *il, integer *iu, real *gers, real *reltol, real * - d__, real *e, real *e2, real *pivmin, integer *nsplit, integer * - isplit, integer *m, real *w, real *werr, real *wl, real *wu, integer * - iblock, integer *indexw, real *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - real r__1, r__2; - - /* Builtin functions */ - double log(doublereal); - - /* Local variables */ - integer i__, j, ib, ie, je, nb; - real gl; - integer im, in; - real gu; - integer iw, jee; - real eps; - integer nwl; - real wlu, wul; - integer nwu; - real tmp1, tmp2; - integer iend, jblk, ioff, iout, itmp1, itmp2, jdisc; - extern logical lsame_(char *, char *); - integer iinfo; - real atoli; - integer iwoff, itmax; - real wkill, rtoli, uflow, tnorm; - integer ibegin, irange, idiscl; - extern doublereal slamch_(char *); - integer idumma[1]; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - integer idiscu; - extern /* Subroutine */ int slaebz_(integer *, integer *, integer *, - integer *, integer *, integer *, real *, real *, real *, real *, - real *, real *, integer *, real *, real *, integer *, integer *, - real *, integer *, integer *); - 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 */ -/* ======= */ - -/* SLARRD computes the eigenvalues of a symmetric tridiagonal */ -/* matrix T to suitable accuracy. This is an auxiliary code to be */ -/* called from SSTEMR. */ -/* 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) REAL */ -/* VU (input) REAL */ -/* 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) REAL array, dimension (2*N) */ -/* The N Gerschgorin intervals (the i-th Gerschgorin interval */ -/* is (GERS(2*i-1), GERS(2*i)). */ - -/* RELTOL (input) REAL */ -/* 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) REAL array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix T. */ - -/* E (input) REAL array, dimension (N-1) */ -/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */ - -/* E2 (input) REAL array, dimension (N-1) */ -/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ - -/* PIVMIN (input) REAL */ -/* 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) REAL array, dimension (N) */ -/* On exit, the first M elements of W will contain the */ -/* eigenvalue approximations. SLARRD 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) REAL array, dimension (N) */ -/* The error bound on the corresponding eigenvalue approximation */ -/* in W. */ - -/* WL (output) REAL */ -/* WU (output) REAL */ -/* 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 SLAEBZ 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. (SLARRD 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) REAL 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 REAL , 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 = slamch_("P"); - uflow = slamch_("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.f; - 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, "SSTEBZ", " ", 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 */ - r__1 = gl, r__2 = gers[(i__ << 1) - 1]; - gl = dmin(r__1,r__2); -/* Computing MAX */ - r__1 = gu, r__2 = gers[i__ * 2]; - gu = dmax(r__1,r__2); -/* L5: */ - } -/* Compute global Gerschgorin bounds and spectral diameter */ -/* Computing MAX */ - r__1 = dabs(gl), r__2 = dabs(gu); - tnorm = dmax(r__1,r__2); - gl = gl - tnorm * 2.f * eps * *n - *pivmin * 4.f; - gu = gu + tnorm * 2.f * eps * *n + *pivmin * 4.f; -/* [JAN/28/2009] remove the line below since SPDIAM variable not use */ -/* SPDIAM = GU - GL */ -/* Input arguments for SLAEBZ: */ -/* 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.f + *pivmin * 4.f; - 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 SLAEBZ. */ - itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.f)) - + 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; - - slaebz_(&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.f; -/* 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 SLAEBZ */ - gu = d__[ibegin]; - gl = d__[ibegin]; - tmp1 = 0.f; - i__2 = iend; - for (j = ibegin; j <= i__2; ++j) { -/* Computing MIN */ - r__1 = gl, r__2 = gers[(j << 1) - 1]; - gl = dmin(r__1,r__2); -/* Computing MAX */ - r__1 = gu, r__2 = gers[j * 2]; - gu = dmax(r__1,r__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.f * eps * in - *pivmin * 2.f; - gu = gu + tnorm * 2.f * eps * in + *pivmin * 2.f; - - 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 = dmax(gl,*wl); - gu = dmin(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; - slaebz_(&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.f)) + 2; - slaebz_(&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 SLAEBZ */ - 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]) * .5f; -/* semi length of error interval */ - tmp2 = (r__1 = work[j + *n] - work[j + in + *n], dabs(r__1)) * - .5f; - 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 SLARRD */ - -} /* slarrd_ */ diff --git a/3rdparty/lapack/slarre.c b/3rdparty/lapack/slarre.c deleted file mode 100644 index becd7a6..0000000 --- a/3rdparty/lapack/slarre.c +++ /dev/null @@ -1,857 +0,0 @@ -/* slarre.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 slarre_(char *range, integer *n, real *vl, real *vu, - integer *il, integer *iu, real *d__, real *e, real *e2, real *rtol1, - real *rtol2, real *spltol, integer *nsplit, integer *isplit, integer * - m, real *w, real *werr, real *wgap, integer *iblock, integer *indexw, - real *gers, real *pivmin, real *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - real r__1, r__2, r__3; - - /* Builtin functions */ - double sqrt(doublereal), log(doublereal); - - /* Local variables */ - integer i__, j; - real s1, s2; - integer mb; - real gl; - integer in, mm; - real gu; - integer cnt; - real eps, tau, tmp, rtl; - integer cnt1, cnt2; - real tmp1, eabs; - integer iend, jblk; - real eold; - integer indl; - real dmax__, emax; - integer wend, idum, indu; - real rtol; - integer iseed[4]; - real avgap, sigma; - extern logical lsame_(char *, char *); - integer iinfo; - logical norep; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), slasq2_(integer *, real *, integer *); - integer ibegin; - logical forceb; - integer irange; - real sgndef; - extern doublereal slamch_(char *); - integer wbegin; - real safmin, spdiam; - extern /* Subroutine */ int slarra_(integer *, real *, real *, real *, - real *, real *, integer *, integer *, integer *); - logical usedqd; - real clwdth, isleft; - extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *, - integer *, real *, real *, integer *, real *, real *, real *, - real *, integer *, real *, real *, integer *, integer *), slarrc_( - char *, integer *, real *, real *, real *, real *, real *, - integer *, integer *, integer *, integer *), slarrd_(char - *, char *, integer *, real *, real *, integer *, integer *, real * -, real *, real *, real *, real *, real *, integer *, integer *, - integer *, real *, real *, real *, real *, integer *, integer *, - real *, integer *, integer *), slarrk_(integer *, - integer *, real *, real *, real *, real *, real *, real *, real *, - real *, integer *); - real isrght, bsrtol, dpivot; - extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real - *); - - -/* -- 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, SLARRE 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 */ -/* SSTEMR 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 SLASQ2) to */ -/* conpute all and then discard any unwanted one. */ -/* As an added benefit, SLARRE 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) REAL */ -/* VU (input/output) REAL */ -/* 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', SLARRE 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) REAL 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) REAL 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) REAL 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) REAL */ -/* RTOL2 (input) REAL */ -/* Parameters for bisection. */ -/* An interval [LEFT,RIGHT] has converged if */ -/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ - -/* SPLTOL (input) REAL */ -/* 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) REAL 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 ( SLARRE may use the */ -/* remaining N-M elements as workspace). */ - -/* WERR (output) REAL array, dimension (N) */ -/* The error bound on the corresponding eigenvalue in W. */ - -/* WGAP (output) REAL 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) REAL 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) REAL array, dimension (6*N) */ -/* Workspace. */ - -/* IWORK (workspace) INTEGER array, dimension (5*N) */ -/* Workspace. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* > 0: A problem occured in SLARRE. */ -/* < 0: One of the called subroutines signaled an internal problem. */ -/* Needs inspection of the corresponding parameter IINFO */ -/* for further information. */ - -/* =-1: Problem in SLARRD. */ -/* = 2: No base representation could be found in MAXTRY iterations. */ -/* Increasing MAXTRY and recompilation might be a remedy. */ -/* =-3: Problem in SLARRB when computing the refined root */ -/* representation for SLASQ2. */ -/* =-4: Problem in SLARRB when preforming bisection on the */ -/* desired part of the spectrum. */ -/* =-5: Problem in SLASQ2. */ -/* =-6: Problem in SLASQ2. */ - -/* 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 = slamch_("S"); - eps = slamch_("P"); -/* Set parameters */ - rtl = eps * 100.f; -/* If one were ever to ask for less initial precision in BSRTOL, */ -/* one should keep in mind that for the subset case, the extremal */ -/* eigenvalues must be at least as accurate as the current setting */ -/* (eigenvalues in the middle need not as much accuracy) */ - bsrtol = sqrt(eps) * 5e-4f; -/* 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.f; - wgap[1] = 0.f; - 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.f; - 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.f; - emax = 0.f; - e[*n] = 0.f; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - werr[i__] = 0.f; - wgap[i__] = 0.f; - eabs = (r__1 = e[i__], dabs(r__1)); - if (eabs >= emax) { - emax = eabs; - } - tmp1 = eabs + eold; - gers[(i__ << 1) - 1] = d__[i__] - tmp1; -/* Computing MIN */ - r__1 = gl, r__2 = gers[(i__ << 1) - 1]; - gl = dmin(r__1,r__2); - gers[i__ * 2] = d__[i__] + tmp1; -/* Computing MAX */ - r__1 = gu, r__2 = gers[i__ * 2]; - gu = dmax(r__1,r__2); - eold = eabs; -/* L5: */ - } -/* The minimum pivot allowed in the Sturm sequence for T */ -/* Computing MAX */ -/* Computing 2nd power */ - r__3 = emax; - r__1 = 1.f, r__2 = r__3 * r__3; - *pivmin = safmin * dmax(r__1,r__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 */ - slarra_(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 SLARRD 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)) */ -/* SLARRD needs a WORK of size 4*N, IWORK of size 3*N */ - slarrd_(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.f; - werr[i__] = 0.f; - 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.f; -/* The gap for a single block doesn't matter for the later */ -/* algorithm and is assigned an arbitrary large value */ - wgap[*m] = 0.f; - iblock[*m] = jblk; - indexw[*m] = 1; - ++wbegin; - } -/* E( IEND ) holds the shift for the initial RRR */ - e[iend] = 0.f; - 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.f; - -/* 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 */ - r__1 = gers[(i__ << 1) - 1]; - gl = dmin(r__1,gl); -/* Computing MAX */ - r__1 = gers[i__ * 2]; - gu = dmax(r__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.f; - ibegin = iend + 1; - goto L170; - } else { -/* Decide whether dqds or bisection is more efficient */ - usedqd = (real) mb > in * .5f && ! 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.f; - i__2 = wend - 1; - for (i__ = wbegin; i__ <= i__2; ++i__) { -/* Computing MAX */ - r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + - werr[i__]); - wgap[i__] = dmax(r__1,r__2); -/* L30: */ - } -/* Computing MAX */ - r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]); - wgap[wend] = dmax(r__1,r__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 */ - slarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & - rtl, &tmp, &tmp1, &iinfo); - if (iinfo != 0) { - *info = -1; - return 0; - } -/* Computing MAX */ - r__2 = gl, r__3 = tmp - tmp1 - eps * 100.f * (r__1 = tmp - tmp1, - dabs(r__1)); - isleft = dmax(r__2,r__3); - slarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & - rtl, &tmp, &tmp1, &iinfo); - if (iinfo != 0) { - *info = -1; - return 0; - } -/* Computing MIN */ - r__2 = gu, r__3 = tmp + tmp1 + eps * 100.f * (r__1 = tmp + tmp1, - dabs(r__1)); - isrght = dmin(r__2,r__3); -/* Improve the estimate of the spectral diameter */ - spdiam = isrght - isleft; - } else { -/* Case of bisection */ -/* Find approximations to the wanted extremal eigenvalues */ -/* Computing MAX */ - r__2 = gl, r__3 = w[wbegin] - werr[wbegin] - eps * 100.f * (r__1 = - w[wbegin] - werr[wbegin], dabs(r__1)); - isleft = dmax(r__2,r__3); -/* Computing MIN */ - r__2 = gu, r__3 = w[wend] + werr[wend] + eps * 100.f * (r__1 = w[ - wend] + werr[wend], dabs(r__1)); - isrght = dmin(r__2,r__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 SLARRE 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 * .25f; - s2 = isrght - spdiam * .25f; - } else { -/* SLARRD has computed IBLOCK and INDEXW for each eigenvalue */ -/* approximation. */ -/* choose sigma */ - if (usedqd) { - s1 = isleft + spdiam * .25f; - s2 = isrght - spdiam * .25f; - } else { - tmp = dmin(isrght,*vu) - dmax(isleft,*vl); - s1 = dmax(isleft,*vl) + tmp * .25f; - s2 = dmin(isrght,*vu) - tmp * .25f; - } - } -/* Compute the negcount at the 1/4 and 3/4 points */ - if (mb > 1) { - slarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, & - cnt, &cnt1, &cnt2, &iinfo); - } - if (mb == 1) { - sigma = gl; - sgndef = 1.f; - } else if (cnt1 - indl >= indu - cnt2) { - if (irange == 1 && ! forceb) { - sigma = dmax(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 = dmax(isleft,*vl); - } - sgndef = 1.f; - } else { - if (irange == 1 && ! forceb) { - sigma = dmin(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 = dmin(isrght,*vu); - } - sgndef = -1.f; - } -/* 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.f; - } else { - if (mb > 1) { - clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin]; - avgap = (r__1 = clwdth / (real) (wend - wbegin), dabs(r__1)); - if (sgndef == 1.f) { -/* Computing MAX */ - r__1 = wgap[wbegin]; - tau = dmax(r__1,avgap) * .5f; -/* Computing MAX */ - r__1 = tau, r__2 = werr[wbegin]; - tau = dmax(r__1,r__2); - } else { -/* Computing MAX */ - r__1 = wgap[wend - 1]; - tau = dmax(r__1,avgap) * .5f; -/* Computing MAX */ - r__1 = tau, r__2 = werr[wend]; - tau = dmax(r__1,r__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__ = dabs(work[1]); - j = ibegin; - i__2 = in - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[(in << 1) + i__] = 1.f / 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 */ - r__1 = dmax__, r__2 = dabs(dpivot); - dmax__ = dmax(r__1,r__2); - ++j; -/* L70: */ - } -/* check for element growth */ - if (dmax__ > spdiam * 64.f) { - 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.f) { - 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.f) { -/* The fudged Gerschgorin shift should succeed */ - sigma = gl - spdiam * 2.f * eps * *n - *pivmin * 4.f; - } else { - sigma = gu + spdiam * 2.f * eps * *n + *pivmin * 4.f; - } - } else { - sigma -= sgndef * tau; - tau *= 2.f; - } - } 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. */ - scopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1); - i__2 = in - 1; - scopy_(&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; - slarnv_(&c__2, iseed, &i__2, &work[1]); - i__2 = in - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - d__[ibegin + i__ - 1] *= eps * 4.f * work[i__] + 1.f; - e[ibegin + i__ - 1] *= eps * 4.f * work[in + i__] + 1.f; -/* L125: */ - } - d__[iend] *= eps * 4.f * work[in] + 1.f; - - } - -/* Don't update the Gerschgorin intervals because keeping track */ -/* of the updates would be too much work in SLARRV. */ -/* 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 SLARRD has been used, shift the eigenvalue approximations */ -/* according to their representation. This is necessary for */ -/* a uniform SLARRV since dqds computes eigenvalues of the */ -/* shifted representation. In SLARRV, W will always hold the */ -/* UNshifted eigenvalue approximation. */ - i__2 = wend; - for (j = wbegin; j <= i__2; ++j) { - w[j] -= sigma; - werr[j] += (r__1 = w[j], dabs(r__1)) * eps; -/* L134: */ - } -/* call SLARRB to reduce eigenvalue error of the approximations */ -/* from SLARRD */ - i__2 = iend - 1; - for (i__ = ibegin; i__ <= i__2; ++i__) { -/* Computing 2nd power */ - r__1 = e[i__]; - work[i__] = d__[i__] * (r__1 * r__1); -/* L135: */ - } -/* use bisection to find EV from INDL to INDU */ - i__2 = indl - 1; - slarrb_(&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; - } -/* SLARRB computes all gaps correctly except for the last one */ -/* Record distance to VU/GU */ -/* Computing MAX */ - r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]); - wgap[wend] = dmax(r__1,r__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 SLASQ2 */ -/* 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((real) in) * 4.f * eps; - j = ibegin; - i__2 = in - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[(i__ << 1) - 1] = (r__1 = d__[j], dabs(r__1)); - work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1]; - ++j; -/* L140: */ - } - work[(in << 1) - 1] = (r__1 = d__[iend], dabs(r__1)); - work[in * 2] = 0.f; - slasq2_(&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.f) { - *info = -6; - return 0; - } -/* L149: */ - } - } - if (sgndef > 0.f) { - 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 SLASQ2 */ - werr[i__] = rtol * (r__1 = w[i__], dabs(r__1)); -/* L165: */ - } - i__2 = *m - 1; - for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { -/* compute the right gap between the intervals */ -/* Computing MAX */ - r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + - werr[i__]); - wgap[i__] = dmax(r__1,r__2); -/* L166: */ - } -/* Computing MAX */ - r__1 = 0.f, r__2 = *vu - sigma - (w[*m] + werr[*m]); - wgap[*m] = dmax(r__1,r__2); - } -/* proceed with next block */ - ibegin = iend + 1; - wbegin = wend + 1; -L170: - ; - } - - return 0; - -/* end of SLARRE */ - -} /* slarre_ */ diff --git a/3rdparty/lapack/slarrf.c b/3rdparty/lapack/slarrf.c deleted file mode 100644 index c74559f..0000000 --- a/3rdparty/lapack/slarrf.c +++ /dev/null @@ -1,422 +0,0 @@ -/* slarrf.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 slarrf_(integer *n, real *d__, real *l, real *ld, - integer *clstrt, integer *clend, real *w, real *wgap, real *werr, - real *spdiam, real *clgapl, real *clgapr, real *pivmin, real *sigma, - real *dplus, real *lplus, real *work, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2, r__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__; - real s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2, znm2, - growthbound, fail, fact, oldp; - integer indx; - real prod; - integer ktry; - real fail2, avgap, ldmax, rdmax; - integer shift; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - logical dorrr1; - real ldelta; - extern doublereal slamch_(char *); - logical nofail; - real mingap, lsigma, rdelta; - logical forcer; - real rsigma, clwdth; - extern logical sisnan_(real *); - 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 ), SLARRF 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) REAL array, dimension (N) */ -/* The N diagonal elements of the diagonal matrix D. */ - -/* L (input) REAL array, dimension (N-1) */ -/* The (N-1) subdiagonal elements of the unit bidiagonal */ -/* matrix L. */ - -/* LD (input) REAL 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) REAL 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) REAL array, dimension >= (CLEND-CLSTRT+1) */ -/* The separation from the right neighbor eigenvalue in W. */ - -/* WERR (input) REAL 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) REAL */ -/* The shift used to form L(+) D(+) L(+)^T. */ - -/* DPLUS (output) REAL array, dimension (N) */ -/* The N diagonal elements of the diagonal matrix D(+). */ - -/* LPLUS (output) REAL array, dimension (N-1) */ -/* The first (N-1) elements of LPLUS contain the subdiagonal */ -/* elements of the unit bidiagonal matrix L(+). */ - -/* WORK (workspace) REAL 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.f; - eps = slamch_("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 = (r__1 = w[*clend] - w[*clstrt], dabs(r__1)) + werr[*clend] + - werr[*clstrt]; - avgap = clwdth / (real) (*clend - *clstrt); - mingap = dmin(*clgapl,*clgapr); -/* Initial values for shifts to both ends of cluster */ -/* Computing MIN */ - r__1 = w[*clstrt], r__2 = w[*clend]; - lsigma = dmin(r__1,r__2) - werr[*clstrt]; -/* Computing MAX */ - r__1 = w[*clstrt], r__2 = w[*clend]; - rsigma = dmax(r__1,r__2) + werr[*clend]; -/* Use a small fudge to make sure that we really shift to the outside */ - lsigma -= dabs(lsigma) * 2.f * eps; - rsigma += dabs(rsigma) * 2.f * eps; -/* Compute upper bounds for how much to back off the initial shifts */ - ldmax = mingap * .25f + *pivmin * 2.f; - rdmax = mingap * .25f + *pivmin * 2.f; -/* Computing MAX */ - r__1 = avgap, r__2 = wgap[*clstrt]; - ldelta = dmax(r__1,r__2) / fact; -/* Computing MAX */ - r__1 = avgap, r__2 = wgap[*clend - 1]; - rdelta = dmax(r__1,r__2) / fact; - -/* Initialize the record of the best representation found */ - - s = slamch_("S"); - smlgrowth = 1.f / s; - fail = (real) (*n - 1) * mingap / (*spdiam * eps); - fail2 = (real) (*n - 1) * mingap / (*spdiam * sqrt(eps)); - bestshift = lsigma; - -/* while (KTRY <= KTRYMAX) */ - ktry = 0; - growthbound = *spdiam * 8.f; -L5: - sawnan1 = FALSE_; - sawnan2 = FALSE_; -/* Ensure that we do not back off too much of the initial shifts */ - ldelta = dmin(ldmax,ldelta); - rdelta = dmin(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 (dabs(dplus[1]) < *pivmin) { - dplus[1] = -(*pivmin); -/* Need to set SAWNAN1 because refined RRR test should not be used */ -/* in this case */ - sawnan1 = TRUE_; - } - max1 = dabs(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 ((r__1 = dplus[i__ + 1], dabs(r__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 */ - r__2 = max1, r__3 = (r__1 = dplus[i__ + 1], dabs(r__1)); - max1 = dmax(r__2,r__3); -/* L6: */ - } - sawnan1 = sawnan1 || sisnan_(&max1); - if (forcer || max1 <= growthbound && ! sawnan1) { - *sigma = lsigma; - shift = 1; - goto L100; - } -/* Right end */ - s = -rsigma; - work[1] = d__[1] + s; - if (dabs(work[1]) < *pivmin) { - work[1] = -(*pivmin); -/* Need to set SAWNAN2 because refined RRR test should not be used */ -/* in this case */ - sawnan2 = TRUE_; - } - max2 = dabs(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 ((r__1 = work[i__ + 1], dabs(r__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 */ - r__2 = max2, r__3 = (r__1 = work[i__ + 1], dabs(r__1)); - max2 = dmax(r__2,r__3); -/* L7: */ - } - sawnan2 = sawnan2 || sisnan_(&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.f && dmin(max1,max2) < fail2 && ! sawnan1 && ! - sawnan2) { - dorrr1 = TRUE_; - } else { - dorrr1 = FALSE_; - } - tryrrr1 = TRUE_; - if (tryrrr1 && dorrr1) { - if (indx == 1) { - tmp = (r__1 = dplus[*n], dabs(r__1)); - znm2 = 1.f; - prod = 1.f; - oldp = 1.f; - 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 *= (r__1 = work[*n + i__], dabs(r__1)); - } - oldp = prod; -/* Computing 2nd power */ - r__1 = prod; - znm2 += r__1 * r__1; -/* Computing MAX */ - r__2 = tmp, r__3 = (r__1 = dplus[i__] * prod, dabs(r__1)); - tmp = dmax(r__2,r__3); -/* L15: */ - } - rrr1 = tmp / (*spdiam * sqrt(znm2)); - if (rrr1 <= 8.f) { - *sigma = lsigma; - shift = 1; - goto L100; - } - } else if (indx == 2) { - tmp = (r__1 = work[*n], dabs(r__1)); - znm2 = 1.f; - prod = 1.f; - oldp = 1.f; - for (i__ = *n - 1; i__ >= 1; --i__) { - if (prod <= eps) { - prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] * - lplus[i__]) * oldp; - } else { - prod *= (r__1 = lplus[i__], dabs(r__1)); - } - oldp = prod; -/* Computing 2nd power */ - r__1 = prod; - znm2 += r__1 * r__1; -/* Computing MAX */ - r__2 = tmp, r__3 = (r__1 = work[i__] * prod, dabs(r__1)); - tmp = dmax(r__2,r__3); -/* L16: */ - } - rrr2 = tmp / (*spdiam * sqrt(znm2)); - if (rrr2 <= 8.f) { - *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 */ - r__1 = lsigma - ldelta, r__2 = lsigma - ldmax; - lsigma = dmax(r__1,r__2); -/* Computing MIN */ - r__1 = rsigma + rdelta, r__2 = rsigma + rdmax; - rsigma = dmin(r__1,r__2); - ldelta *= 2.f; - rdelta *= 2.f; - ++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 */ - scopy_(n, &work[1], &c__1, &dplus[1], &c__1); - i__1 = *n - 1; - scopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1); - } - return 0; - -/* End of SLARRF */ - -} /* slarrf_ */ diff --git a/3rdparty/lapack/slarrj.c b/3rdparty/lapack/slarrj.c deleted file mode 100644 index 69e836e..0000000 --- a/3rdparty/lapack/slarrj.c +++ /dev/null @@ -1,337 +0,0 @@ -/* slarrj.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 slarrj_(integer *n, real *d__, real *e2, integer *ifirst, - integer *ilast, real *rtol, integer *offset, real *w, real *werr, - real *work, integer *iwork, real *pivmin, real *spdiam, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - real r__1, r__2; - - /* Builtin functions */ - double log(doublereal); - - /* Local variables */ - integer i__, j, k, p; - real s; - integer i1, i2, ii; - real fac, mid; - integer cnt; - real tmp, left; - integer iter, nint, prev, next, savi1; - real 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, SLARRJ */ -/* 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) REAL array, dimension (N) */ -/* The N diagonal elements of T. */ - -/* E2 (input) REAL 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) REAL */ -/* 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) REAL 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) REAL 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) REAL 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.f)) + - 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 */ - r__1 = dabs(left), r__2 = dabs(right); - tmp = dmax(r__1,r__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.f; -L20: - cnt = 0; - s = left; - dplus = d__[1] - s; - if (dplus < 0.f) { - ++cnt; - } - i__2 = *n; - for (j = 2; j <= i__2; ++j) { - dplus = d__[j] - s - e2[j - 1] / dplus; - if (dplus < 0.f) { - ++cnt; - } -/* L30: */ - } - if (cnt > i__ - 1) { - left -= werr[ii] * fac; - fac *= 2.f; - goto L20; - } - -/* Do while( CNT(RIGHT).LT.I ) */ - - fac = 1.f; -L50: - cnt = 0; - s = right; - dplus = d__[1] - s; - if (dplus < 0.f) { - ++cnt; - } - i__2 = *n; - for (j = 2; j <= i__2; ++j) { - dplus = d__[j] - s - e2[j - 1] / dplus; - if (dplus < 0.f) { - ++cnt; - } -/* L60: */ - } - if (cnt < i__) { - right += werr[ii] * fac; - fac *= 2.f; - 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) * .5f; -/* semiwidth of interval */ - width = right - mid; -/* Computing MAX */ - r__1 = dabs(left), r__2 = dabs(right); - tmp = dmax(r__1,r__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.f) { - ++cnt; - } - i__2 = *n; - for (j = 2; j <= i__2; ++j) { - dplus = d__[j] - s - e2[j - 1] / dplus; - if (dplus < 0.f) { - ++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]) * .5f; - werr[ii] = work[k] - w[ii]; - } -/* L110: */ - } - - return 0; - -/* End of SLARRJ */ - -} /* slarrj_ */ diff --git a/3rdparty/lapack/slarrk.c b/3rdparty/lapack/slarrk.c deleted file mode 100644 index b2ac4c0..0000000 --- a/3rdparty/lapack/slarrk.c +++ /dev/null @@ -1,193 +0,0 @@ -/* slarrk.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 slarrk_(integer *n, integer *iw, real *gl, real *gu, - real *d__, real *e2, real *pivmin, real *reltol, real *w, real *werr, - integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Builtin functions */ - double log(doublereal); - - /* Local variables */ - integer i__, it; - real mid, eps, tmp1, tmp2, left, atoli, right; - integer itmax; - real rtoli, tnorm; - extern doublereal slamch_(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 */ -/* ======= */ - -/* SLARRK computes one eigenvalue of a symmetric tridiagonal */ -/* matrix T to suitable accuracy. This is an auxiliary code to be */ -/* called from SSTEMR. */ - -/* 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) REAL */ -/* GU (input) REAL */ -/* An upper and a lower bound on the eigenvalue. */ - -/* D (input) REAL array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix T. */ - -/* E2 (input) REAL array, dimension (N-1) */ -/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ - -/* PIVMIN (input) REAL */ -/* The minimum pivot allowed in the Sturm sequence for T. */ - -/* RELTOL (input) REAL */ -/* 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) REAL */ - -/* WERR (output) REAL */ -/* The error bound on the corresponding eigenvalue approximation */ -/* in W. */ - -/* INFO (output) INTEGER */ -/* = 0: Eigenvalue converged */ -/* = -1: Eigenvalue did NOT converge */ - -/* Internal Parameters */ -/* =================== */ - -/* FUDGE REAL , 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 = slamch_("P"); -/* Computing MAX */ - r__1 = dabs(*gl), r__2 = dabs(*gu); - tnorm = dmax(r__1,r__2); - rtoli = *reltol; - atoli = *pivmin * 4.f; - itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.f)) + 2; - *info = -1; - left = *gl - tnorm * 2.f * eps * *n - *pivmin * 4.f; - right = *gu + tnorm * 2.f * eps * *n + *pivmin * 4.f; - it = 0; -L10: - -/* Check if interval converged or maximum number of iterations reached */ - - tmp1 = (r__1 = right - left, dabs(r__1)); -/* Computing MAX */ - r__1 = dabs(right), r__2 = dabs(left); - tmp2 = dmax(r__1,r__2); -/* Computing MAX */ - r__1 = max(atoli,*pivmin), r__2 = rtoli * tmp2; - if (tmp1 < dmax(r__1,r__2)) { - *info = 0; - goto L30; - } - if (it > itmax) { - goto L30; - } - -/* Count number of negative pivots for mid-point */ - - ++it; - mid = (left + right) * .5f; - negcnt = 0; - tmp1 = d__[1] - mid; - if (dabs(tmp1) < *pivmin) { - tmp1 = -(*pivmin); - } - if (tmp1 <= 0.f) { - ++negcnt; - } - - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - tmp1 = d__[i__] - e2[i__ - 1] / tmp1 - mid; - if (dabs(tmp1) < *pivmin) { - tmp1 = -(*pivmin); - } - if (tmp1 <= 0.f) { - ++negcnt; - } -/* L20: */ - } - if (negcnt >= *iw) { - right = mid; - } else { - left = mid; - } - goto L10; -L30: - -/* Converged or maximum number of iterations reached */ - - *w = (left + right) * .5f; - *werr = (r__1 = right - left, dabs(r__1)) * .5f; - return 0; - -/* End of SLARRK */ - -} /* slarrk_ */ diff --git a/3rdparty/lapack/slarrr.c b/3rdparty/lapack/slarrr.c deleted file mode 100644 index 291c80f..0000000 --- a/3rdparty/lapack/slarrr.c +++ /dev/null @@ -1,175 +0,0 @@ -/* slarrr.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 slarrr_(integer *n, real *d__, real *e, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__; - real eps, tmp, tmp2, rmin, offdig; - extern doublereal slamch_(char *); - real safmin; - logical yesrel; - real 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) REAL array, dimension (N) */ -/* The N diagonal elements of the tridiagonal matrix T. */ - -/* E (input/output) REAL 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 = slamch_("Safe minimum"); - eps = slamch_("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.f; - tmp = sqrt((dabs(d__[1]))); - if (tmp < rmin) { - yesrel = FALSE_; - } - if (! yesrel) { - goto L11; - } - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - tmp2 = sqrt((r__1 = d__[i__], dabs(r__1))); - if (tmp2 < rmin) { - yesrel = FALSE_; - } - if (! yesrel) { - goto L11; - } - offdig2 = (r__1 = e[i__ - 1], dabs(r__1)) / (tmp * tmp2); - if (offdig + offdig2 >= .999f) { - 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 SLARRR */ - -} /* slarrr_ */ diff --git a/3rdparty/lapack/slarrv.c b/3rdparty/lapack/slarrv.c deleted file mode 100644 index 35ff9c8..0000000 --- a/3rdparty/lapack/slarrv.c +++ /dev/null @@ -1,980 +0,0 @@ -/* slarrv.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 real c_b5 = 0.f; -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int slarrv_(integer *n, real *vl, real *vu, real *d__, real * - l, real *pivmin, integer *isplit, integer *m, integer *dol, integer * - dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr, - real *wgap, integer *iblock, integer *indexw, real *gers, real *z__, - integer *ldz, integer *isuppz, real *work, integer *iwork, integer * - info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; - real r__1, r__2; - logical L__1; - - /* Builtin functions */ - double log(doublereal); - - /* Local variables */ - integer minwsize, i__, j, k, p, q, miniwsize, ii; - real gl; - integer im, in; - real gu, gap, eps, tau, tol, tmp; - integer zto; - real ztz; - integer iend, jblk; - real lgap; - integer done; - real rgap, left; - integer wend, iter; - real bstw; - integer itmp1, indld; - real fudge; - integer idone; - real sigma; - integer iinfo, iindr; - real resid; - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - logical eskip; - real right; - integer nclus, zfrom; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - real rqtol; - integer iindc1, iindc2; - extern /* Subroutine */ int slar1v_(integer *, integer *, integer *, real - *, real *, real *, real *, real *, real *, real *, real *, - logical *, integer *, real *, real *, integer *, integer *, real * -, real *, real *, real *); - logical stp2ii; - real lambda; - integer ibegin, indeig; - logical needbs; - integer indlld; - real sgndef, mingma; - extern doublereal slamch_(char *); - integer oldien, oldncl, wbegin; - real spdiam; - integer negcnt, oldcls; - real savgap; - integer ndepth; - real ssigma; - logical usedbs; - integer iindwk, offset; - real gaptol; - extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *, - integer *, real *, real *, integer *, real *, real *, real *, - real *, integer *, real *, real *, integer *, integer *), slarrf_( - integer *, real *, real *, real *, integer *, integer *, real *, - real *, real *, real *, real *, real *, real *, real *, real *, - real *, real *, integer *); - integer newcls, oldfst, indwrk, windex, oldlst; - logical usedrq; - integer newfst, newftt, parity, windmn, isupmn, newlst, windpl, zusedl, - newsiz, zusedu, zusedw; - real bstres, nrminv; - logical tryrqc; - integer isupmx; - real rqcorr; - extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, - real *, real *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLARRV 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 SLARRE. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* VL (input) REAL */ -/* VU (input) REAL */ -/* 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) REAL array, dimension (N) */ -/* On entry, the N diagonal elements of the diagonal matrix D. */ -/* On exit, D may be overwritten. */ - -/* L (input/output) REAL 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 SLARRE. */ -/* 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) REAL */ - -/* RTOL1 (input) REAL */ -/* RTOL2 (input) REAL */ -/* Parameters for bisection. */ -/* An interval [LEFT,RIGHT] has converged if */ -/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ - -/* W (input/output) REAL 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 SLARRE 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) REAL array, dimension (N) */ -/* The first M elements contain the semiwidth of the uncertainty */ -/* interval of the corresponding eigenvalue in W */ - -/* WGAP (input/output) REAL 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) REAL 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) REAL 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) REAL array, dimension (12*N) */ - -/* IWORK (workspace) INTEGER array, dimension (7*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ - -/* > 0: A problem occured in SLARRV. */ -/* < 0: One of the called subroutines signaled an internal problem. */ -/* Needs inspection of the corresponding parameter IINFO */ -/* for further information. */ - -/* =-1: Problem in SLARRB when refining a child's eigenvalues. */ -/* =-2: Problem in SLARRF 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 SLARRB 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.f; -/* 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; - slaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz); - eps = slamch_("Precision"); - rqtol = eps * 2.f; - -/* 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.f; - *rtol2 = eps * 4.f; - } -/* 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 */ - r__1 = gers[(i__ << 1) - 1]; - gl = dmin(r__1,gl); -/* Computing MAX */ - r__1 = gers[i__ * 2]; - gu = dmax(r__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.f; - 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. */ - scopy_(&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; - } - } - scopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin] -, &c__1); - i__3 = in - 1; - scopy_(&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 */ - slaset_("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. */ - slarrb_(&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 SLARRB. */ -/* However, we only allow the gaps to become greater since */ -/* this is what should happen when we decrease WERR */ - if (oldfst > 1) { -/* Computing MAX */ - r__1 = wgap[wbegin + oldfst - 2], r__2 = w[wbegin + - oldfst - 1] - werr[wbegin + oldfst - 1] - w[ - wbegin + oldfst - 2] - werr[wbegin + oldfst - - 2]; - wgap[wbegin + oldfst - 2] = dmax(r__1,r__2); - } - if (wbegin + oldlst - 1 < wend) { -/* Computing MAX */ - r__1 = wgap[wbegin + oldlst - 1], r__2 = w[wbegin + - oldlst] - werr[wbegin + oldlst] - w[wbegin + - oldlst - 1] - werr[wbegin + oldlst - 1]; - wgap[wbegin + oldlst - 1] = dmax(r__1,r__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 * (r__1 = work[ - wbegin + j - 1], dabs(r__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 */ - r__1 = 0.f, r__2 = w[wbegin] - werr[wbegin] - *vl; - lgap = dmax(r__1,r__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; - slarrb_(&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 */ - -/* SLARRF needs LWORK = 2*N */ - slarrf_(&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 SLARRF */ -/* 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.f * (r__1 = work[wbegin + k - - 1], dabs(r__1)); - work[wbegin + k - 1] -= tau; - fudge += eps * 4.f * (r__1 = work[wbegin + k - - 1], dabs(r__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((real) in) * 4.f * 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 */ - r__1 = dabs(left), r__2 = dabs(right); - lgap = eps * dmax(r__1,r__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 */ - r__1 = dabs(left), r__2 = dabs(right); - rgap = eps * dmax(r__1,r__2); - } else { - rgap = wgap[windex]; - } - gap = dmin(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.f; - } 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; - r__1 = eps * 2.f; - slarrb_(&in, &d__[ibegin], &work[indlld + ibegin - - 1], &indeig, &indeig, &c_b5, &r__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; - slar1v_(&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 && dabs(rqcorr) > rqtol * dabs( - 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.f; - } else { -/* The wanted eigenvalue lies to the right */ - sgndef = 1.f; - } -/* We only use the RQCORR if it improves the */ -/* the iterate reasonably. */ - if (rqcorr * sgndef >= 0.f && lambda + rqcorr <= - right && lambda + rqcorr >= left) { - usedrq = TRUE_; -/* Store new midpoint of bisection interval in WORK */ - if (sgndef == 1.f) { -/* 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) * .5f; -/* Take RQCORR since it has the correct sign and */ -/* improves the iterate reasonably */ - lambda += rqcorr; -/* Update width of error interval */ - werr[windex] = (right - left) * .5f; - } else { - needbs = TRUE_; - } - if (right - left < rqtol * dabs(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; - slar1v_(&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.f; -/* L122: */ - } - } - if (isupmx > zto) { - i__4 = isupmx; - for (ii = zto + 1; ii <= i__4; ++ii) { - z__[ii + windex * z_dim1] = 0.f; -/* L123: */ - } - } - i__4 = zto - zfrom + 1; - sscal_(&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 */ - r__1 = wgap[windmn], r__2 = w[windex] - werr[ - windex] - w[windmn] - werr[windmn]; - wgap[windmn] = dmax(r__1,r__2); - } - if (windex < wend) { -/* Computing MAX */ - r__1 = savgap, r__2 = w[windpl] - werr[windpl] - - w[windex] - werr[windex]; - wgap[windex] = dmax(r__1,r__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 SLARRV */ - -} /* slarrv_ */ diff --git a/3rdparty/lapack/slartg_custom.c b/3rdparty/lapack/slartg_custom.c deleted file mode 100644 index b3b403e..0000000 --- a/3rdparty/lapack/slartg_custom.c +++ /dev/null @@ -1,174 +0,0 @@ -#include "clapack.h" - - -/* Subroutine */ int slartg_(real *f, real *g, real *cs, real *sn, real *r__) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Local variables */ - integer i__; - real f1, g1, eps, scale; - integer count; - static real safmn2, safmx2; - static real safmin; - static logical FIRST = TRUE_; - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLARTG 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 SROTG, */ -/* 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 SBDSQR when */ -/* there are zeros on the diagonal). */ - -/* If F exceeds G in magnitude, CS will be positive. */ - -/* Arguments */ -/* ========= */ - -/* F (input) REAL */ -/* The first component of vector to be rotated. */ - -/* G (input) REAL */ -/* The second component of vector to be rotated. */ - -/* CS (output) REAL */ -/* The cosine of the rotation. */ - -/* SN (output) REAL */ -/* The sine of the rotation. */ - -/* R (output) REAL */ -/* 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 = slamch_("S"); - eps = slamch_("E"); - r__1 = slamch_("B"); - i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f); - safmn2 = pow_ri(&r__1, &i__1); - safmx2 = 1.f / safmn2; - FIRST = FALSE_; - } - if (*g == 0.f) { - *cs = 1.f; - *sn = 0.f; - *r__ = *f; - } else if (*f == 0.f) { - *cs = 0.f; - *sn = 1.f; - *r__ = *g; - } else { - f1 = *f; - g1 = *g; -/* Computing MAX */ - r__1 = dabs(f1), r__2 = dabs(g1); - scale = dmax(r__1,r__2); - if (scale >= safmx2) { - count = 0; -L10: - ++count; - f1 *= safmn2; - g1 *= safmn2; -/* Computing MAX */ - r__1 = dabs(f1), r__2 = dabs(g1); - scale = dmax(r__1,r__2); - if (scale >= safmx2) { - goto L10; - } -/* Computing 2nd power */ - r__1 = f1; -/* Computing 2nd power */ - r__2 = g1; - *r__ = sqrt(r__1 * r__1 + r__2 * r__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 */ - r__1 = dabs(f1), r__2 = dabs(g1); - scale = dmax(r__1,r__2); - if (scale <= safmn2) { - goto L30; - } -/* Computing 2nd power */ - r__1 = f1; -/* Computing 2nd power */ - r__2 = g1; - *r__ = sqrt(r__1 * r__1 + r__2 * r__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - i__1 = count; - for (i__ = 1; i__ <= i__1; ++i__) { - *r__ *= safmn2; -/* L40: */ - } - } else { -/* Computing 2nd power */ - r__1 = f1; -/* Computing 2nd power */ - r__2 = g1; - *r__ = sqrt(r__1 * r__1 + r__2 * r__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - } - if (dabs(*f) > dabs(*g) && *cs < 0.f) { - *cs = -(*cs); - *sn = -(*sn); - *r__ = -(*r__); - } - } - return 0; - -/* End of SLARTG */ - -} /* slartg_ */ diff --git a/3rdparty/lapack/slaruv.c b/3rdparty/lapack/slaruv.c deleted file mode 100644 index 60e2333..0000000 --- a/3rdparty/lapack/slaruv.c +++ /dev/null @@ -1,193 +0,0 @@ -/* slaruv.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 slaruv_(integer *iseed, integer *n, real *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 */ -/* ======= */ - -/* SLARUV returns a vector of n random real numbers from a uniform (0,1) */ -/* distribution (n <= 128). */ - -/* This is an auxiliary routine called by SLARNV and CLARNV. */ - -/* 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) REAL 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__] = ((real) it1 + ((real) it2 + ((real) it3 + (real) it4 * - 2.44140625e-4f) * 2.44140625e-4f) * 2.44140625e-4f) * - 2.44140625e-4f; - - if (x[i__] == 1.f) { -/* 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. In IEEE single precision arithmetic, */ -/* this will happen relatively often since n = 24. */ -/* 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 SLARUV */ - -} /* slaruv_ */ diff --git a/3rdparty/lapack/slas2.c b/3rdparty/lapack/slas2.c deleted file mode 100644 index a65cfe5..0000000 --- a/3rdparty/lapack/slas2.c +++ /dev/null @@ -1,145 +0,0 @@ -/* slas2.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 slas2_(real *f, real *g, real *h__, real *ssmin, real * - ssmax) -{ - /* System generated locals */ - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real 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 */ -/* ======= */ - -/* SLAS2 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) REAL */ -/* The (1,1) element of the 2-by-2 matrix. */ - -/* G (input) REAL */ -/* The (1,2) element of the 2-by-2 matrix. */ - -/* H (input) REAL */ -/* The (2,2) element of the 2-by-2 matrix. */ - -/* SSMIN (output) REAL */ -/* The smaller singular value. */ - -/* SSMAX (output) REAL */ -/* 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 = dabs(*f); - ga = dabs(*g); - ha = dabs(*h__); - fhmn = dmin(fa,ha); - fhmx = dmax(fa,ha); - if (fhmn == 0.f) { - *ssmin = 0.f; - if (fhmx == 0.f) { - *ssmax = ga; - } else { -/* Computing 2nd power */ - r__1 = dmin(fhmx,ga) / dmax(fhmx,ga); - *ssmax = dmax(fhmx,ga) * sqrt(r__1 * r__1 + 1.f); - } - } else { - if (ga < fhmx) { - as = fhmn / fhmx + 1.f; - at = (fhmx - fhmn) / fhmx; -/* Computing 2nd power */ - r__1 = ga / fhmx; - au = r__1 * r__1; - c__ = 2.f / (sqrt(as * as + au) + sqrt(at * at + au)); - *ssmin = fhmn * c__; - *ssmax = fhmx / c__; - } else { - au = fhmx / ga; - if (au == 0.f) { - -/* 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.f; - at = (fhmx - fhmn) / fhmx; -/* Computing 2nd power */ - r__1 = as * au; -/* Computing 2nd power */ - r__2 = at * au; - c__ = 1.f / (sqrt(r__1 * r__1 + 1.f) + sqrt(r__2 * r__2 + 1.f) - ); - *ssmin = fhmn * c__ * au; - *ssmin += *ssmin; - *ssmax = ga / (c__ + c__); - } - } - } - return 0; - -/* End of SLAS2 */ - -} /* slas2_ */ diff --git a/3rdparty/lapack/slascl.c b/3rdparty/lapack/slascl.c deleted file mode 100644 index f8afad7..0000000 --- a/3rdparty/lapack/slascl.c +++ /dev/null @@ -1,355 +0,0 @@ -/* slascl.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 slascl_(char *type__, integer *kl, integer *ku, real * - cfrom, real *cto, integer *m, integer *n, real *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; - real mul, cto1; - logical done; - real ctoc; - extern logical lsame_(char *, char *); - integer itype; - real cfrom1; - extern doublereal slamch_(char *); - real cfromc; - extern /* Subroutine */ int xerbla_(char *, integer *); - real bignum; - extern logical sisnan_(real *); - real smlnum; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASCL 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) REAL */ -/* CTO (input) REAL */ -/* 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) REAL 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.f || sisnan_(cfrom)) { - *info = -4; - } else if (sisnan_(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_("SLASCL", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *m == 0) { - return 0; - } - -/* Get machine parameters */ - - smlnum = slamch_("S"); - bignum = 1.f / 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.f; - } else if (dabs(cfrom1) > dabs(ctoc) && ctoc != 0.f) { - mul = smlnum; - done = FALSE_; - cfromc = cfrom1; - } else if (dabs(cto1) > dabs(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 SLASCL */ - -} /* slascl_ */ diff --git a/3rdparty/lapack/slasd0.c b/3rdparty/lapack/slasd0.c deleted file mode 100644 index 9906433..0000000 --- a/3rdparty/lapack/slasd0.c +++ /dev/null @@ -1,286 +0,0 @@ -/* slasd0.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 slasd0_(integer *n, integer *sqre, real *d__, real *e, - real *u, integer *ldu, real *vt, integer *ldvt, integer *smlsiz, - integer *iwork, real *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; - real beta; - integer idxq, nlvl; - real alpha; - integer inode, ndiml, idxqc, ndimr, itemp, sqrei; - extern /* Subroutine */ int slasd1_(integer *, integer *, integer *, real - *, real *, real *, real *, integer *, real *, integer *, integer * -, integer *, real *, integer *), xerbla_(char *, integer *), slasdq_(char *, integer *, integer *, integer *, integer - *, integer *, real *, real *, real *, integer *, real *, integer * -, real *, integer *, real *, integer *), slasdt_(integer * -, integer *, integer *, integer *, integer *, integer *, 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, SLASD0 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, SLASDA, 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) REAL 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) REAL array, dimension (M-1) */ -/* Contains the subdiagonal entries of the bidiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* U (output) REAL 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) REAL 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 array, dimension (8*N) */ - -/* WORK (workspace) REAL 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 */ - -/* ===================================================================== */ - -/* .. 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_("SLASD0", &i__1); - return 0; - } - -/* If the input matrix is too small, call SLASDQ to find the SVD. */ - - if (*n <= *smlsiz) { - slasdq_("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; - slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], - smlsiz); - -/* For the nodes on bottom level of the tree, solve */ -/* their subproblems by SLASDQ. */ - - 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; - slasdq_("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; - slasdq_("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]; - slasd1_(&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 SLASD0 */ - -} /* slasd0_ */ diff --git a/3rdparty/lapack/slasd1.c b/3rdparty/lapack/slasd1.c deleted file mode 100644 index 3da0399..0000000 --- a/3rdparty/lapack/slasd1.c +++ /dev/null @@ -1,286 +0,0 @@ -/* slasd1.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 real c_b7 = 1.f; -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int slasd1_(integer *nl, integer *nr, integer *sqre, real * - d__, real *alpha, real *beta, real *u, integer *ldu, real *vt, - integer *ldvt, integer *idxq, integer *iwork, real *work, integer * - info) -{ - /* System generated locals */ - integer u_dim1, u_offset, vt_dim1, vt_offset, i__1; - real r__1, r__2; - - /* Local variables */ - integer i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc, - idxp, ldvt2; - extern /* Subroutine */ int slasd2_(integer *, integer *, integer *, - integer *, real *, real *, real *, real *, real *, integer *, - real *, integer *, real *, real *, integer *, real *, integer *, - integer *, integer *, integer *, integer *, integer *, integer *), - slasd3_(integer *, integer *, integer *, integer *, real *, real - *, integer *, real *, real *, integer *, real *, integer *, real * -, integer *, real *, integer *, integer *, integer *, real *, - integer *); - integer isigma; - extern /* Subroutine */ int xerbla_(char *, integer *), slascl_( - char *, integer *, integer *, real *, real *, integer *, integer * -, real *, integer *, integer *), slamrg_(integer *, - integer *, real *, integer *, integer *, integer *); - real 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 */ -/* ======= */ - -/* SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, */ -/* where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0. */ - -/* A related subroutine SLASD7 handles the case in which the singular */ -/* values (and the singular vectors in factored form) are desired. */ - -/* SLASD1 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 SLASD2. */ - -/* 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 SLASD4 (as called */ -/* by SLASD3). 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) REAL array, dimension (NL+NR+1). */ -/* 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) REAL */ -/* Contains the diagonal element associated with the added row. */ - -/* BETA (input/output) REAL */ -/* Contains the off-diagonal element associated with the added */ -/* row. */ - -/* U (input/output) REAL 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) REAL 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) REAL 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_("SLASD1", &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 SLASD2 and SLASD3. */ - - 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 */ - r__1 = dabs(*alpha), r__2 = dabs(*beta); - orgnrm = dmax(r__1,r__2); - d__[*nl + 1] = 0.f; - i__1 = n; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((r__1 = d__[i__], dabs(r__1)) > orgnrm) { - orgnrm = (r__1 = d__[i__], dabs(r__1)); - } -/* L10: */ - } - slascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info); - *alpha /= orgnrm; - *beta /= orgnrm; - -/* Deflate singular values. */ - - slasd2_(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; - slasd3_(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. */ - - slascl_("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; - slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]); - - return 0; - -/* End of SLASD1 */ - -} /* slasd1_ */ diff --git a/3rdparty/lapack/slasd2.c b/3rdparty/lapack/slasd2.c deleted file mode 100644 index 0bf7e2a..0000000 --- a/3rdparty/lapack/slasd2.c +++ /dev/null @@ -1,607 +0,0 @@ -/* slasd2.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 real c_b30 = 0.f; - -/* Subroutine */ int slasd2_(integer *nl, integer *nr, integer *sqre, integer - *k, real *d__, real *z__, real *alpha, real *beta, real *u, integer * - ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2, - real *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; - real r__1, r__2; - - /* Local variables */ - real c__; - integer i__, j, m, n; - real s; - integer k2; - real z1; - integer ct, jp; - real eps, tau, tol; - integer psm[4], nlp1, nlp2, idxi, idxj, ctot[4]; - extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, - integer *, real *, real *); - integer idxjp, jprev; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - extern doublereal slapy2_(real *, real *), slamch_(char *); - extern /* Subroutine */ int xerbla_(char *, integer *), slamrg_( - integer *, integer *, real *, integer *, integer *, integer *); - real hlftol; - extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, - integer *, real *, integer *), slaset_(char *, integer *, - integer *, real *, real *, real *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASD2 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. */ - -/* SLASD2 is called from SLASD1. */ - -/* 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) REAL 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) REAL array, dimension (N) */ -/* On exit Z contains the updating row vector in the secular */ -/* equation. */ - -/* ALPHA (input) REAL */ -/* Contains the diagonal element associated with the added row. */ - -/* BETA (input) REAL */ -/* Contains the off-diagonal element associated with the added */ -/* row. */ - -/* U (input/output) REAL 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) REAL 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) REAL array, dimension (N) */ -/* Contains a copy of the diagonal elements (K-1 singular values */ -/* and one zero) in the secular equation. */ - -/* U2 (output) REAL array, dimension (LDU2,N) */ -/* Contains a copy of the first K-1 left singular vectors which */ -/* will be used by SLASD3 in a matrix multiply (SGEMM) 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) REAL array, dimension (LDVT2,N) */ -/* VT2' contains a copy of the first K right singular vectors */ -/* which will be used by SLASD3 in a matrix multiply (SGEMM) 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_("SLASD2", &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: */ - } - - slamrg_(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 = slamch_("Epsilon"); -/* Computing MAX */ - r__1 = dabs(*alpha), r__2 = dabs(*beta); - tol = dmax(r__1,r__2); -/* Computing MAX */ - r__2 = (r__1 = d__[n], dabs(r__1)); - tol = eps * 8.f * dmax(r__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 ((r__1 = z__[j], dabs(r__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 ((r__1 = z__[j], dabs(r__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 ((r__1 = d__[j] - d__[jprev], dabs(r__1)) <= tol) { - -/* Deflation is possible. */ - - s = z__[jprev]; - c__ = z__[j]; - -/* Find sqrt(a**2+b**2) without overflow or */ -/* destructive underflow. */ - - tau = slapy2_(&c__, &s); - c__ /= tau; - s = -s / tau; - z__[j] = tau; - z__[jprev] = 0.f; - -/* 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; - } - srot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], & - c__1, &c__, &s); - srot_(&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; - } - scopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1); - scopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2); -/* L160: */ - } - -/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */ - - dsigma[1] = 0.f; - hlftol = tol / 2.f; - if (dabs(dsigma[2]) <= hlftol) { - dsigma[2] = hlftol; - } - if (m > n) { - z__[1] = slapy2_(&z1, &z__[m]); - if (z__[1] <= tol) { - c__ = 1.f; - s = 0.f; - z__[1] = tol; - } else { - c__ = z1 / z__[1]; - s = z__[m] / z__[1]; - } - } else { - if (dabs(z1) <= tol) { - z__[1] = tol; - } else { - z__[1] = z1; - } - } - -/* Move the rest of the updating row to Z. */ - - i__1 = *k - 1; - scopy_(&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. */ - - slaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2); - u2[nlp1 + u2_dim1] = 1.f; - 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 { - scopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2); - } - if (m > n) { - scopy_(&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; - scopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1); - i__1 = n - *k; - slacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1) - * u_dim1 + 1], ldu); - i__1 = n - *k; - slacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 + - vt_dim1], ldvt); - } - -/* Copy CTOT into COLTYP for referencing in SLASD3. */ - - for (j = 1; j <= 4; ++j) { - coltyp[j] = ctot[j - 1]; -/* L190: */ - } - - return 0; - -/* End of SLASD2 */ - -} /* slasd2_ */ diff --git a/3rdparty/lapack/slasd3.c b/3rdparty/lapack/slasd3.c deleted file mode 100644 index 9b5fa7b..0000000 --- a/3rdparty/lapack/slasd3.c +++ /dev/null @@ -1,450 +0,0 @@ -/* slasd3.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 real c_b13 = 1.f; -static real c_b26 = 0.f; - -/* Subroutine */ int slasd3_(integer *nl, integer *nr, integer *sqre, integer - *k, real *d__, real *q, integer *ldq, real *dsigma, real *u, integer * - ldu, real *u2, integer *ldu2, real *vt, integer *ldvt, real *vt2, - integer *ldvt2, integer *idxc, integer *ctot, real *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; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal), r_sign(real *, real *); - - /* Local variables */ - integer i__, j, m, n, jc; - real rho; - integer nlp1, nlp2, nrp1; - real temp; - extern doublereal snrm2_(integer *, real *, integer *); - integer ctemp; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - integer ktemp; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - extern doublereal slamc3_(real *, real *); - extern /* Subroutine */ int slasd4_(integer *, integer *, real *, real *, - real *, real *, real *, real *, integer *), xerbla_(char *, - integer *), slascl_(char *, integer *, integer *, real *, - real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, - real *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASD3 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 SLASD4 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. */ - -/* SLASD3 is called from SLASD1. */ - -/* 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) REAL array, dimension(K) */ -/* On exit the square roots of the roots of the secular equation, */ -/* in ascending order. */ - -/* Q (workspace) REAL array, */ -/* dimension at least (LDQ,K). */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= K. */ - -/* DSIGMA (input/output) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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 SLASD4 */ -/* 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/output) REAL 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_("SLASD3", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*k == 1) { - d__[1] = dabs(z__[1]); - scopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt); - if (z__[1] > 0.f) { - scopy_(&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__] = slamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; -/* L20: */ - } - -/* Keep a copy of Z. */ - - scopy_(k, &z__[1], &c__1, &q[q_offset], &c__1); - -/* Normalize Z. */ - - rho = snrm2_(k, &z__[1], &c__1); - slascl_("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) { - slasd4_(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: */ - } - r__2 = sqrt((r__1 = z__[i__], dabs(r__1))); - z__[i__] = r_sign(&r__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.f; - 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 = snrm2_(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) { - sgemm_("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) { - sgemm_("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]; - sgemm_("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]; - sgemm_("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 { - slacpy_("F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu); - } - scopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu); - ktemp = ctot[1] + 2; - ctemp = ctot[2] + ctot[3]; - sgemm_("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 = snrm2_(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) { - sgemm_("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; - sgemm_("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) { - sgemm_("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]; - sgemm_("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 SLASD3 */ - -} /* slasd3_ */ diff --git a/3rdparty/lapack/slasd4.c b/3rdparty/lapack/slasd4.c deleted file mode 100644 index b57b231..0000000 --- a/3rdparty/lapack/slasd4.c +++ /dev/null @@ -1,1010 +0,0 @@ -/* slasd4.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 slasd4_(integer *n, integer *i__, real *d__, real *z__, - real *delta, real *rho, real *sigma, real *work, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real a, b, c__; - integer j; - real w, dd[3]; - integer ii; - real dw, zz[3]; - integer ip1; - real eta, phi, eps, tau, psi; - integer iim1, iip1; - real dphi, dpsi; - integer iter; - real temp, prew, sg2lb, sg2ub, temp1, temp2, dtiim, delsq, dtiip; - integer niter; - real dtisq; - logical swtch; - real dtnsq; - extern /* Subroutine */ int slaed6_(integer *, logical *, real *, real *, - real *, real *, real *, integer *); - real delsq2; - extern /* Subroutine */ int slasd5_(integer *, real *, real *, real *, - real *, real *, real *); - real dtnsq1; - logical swtch3; - extern doublereal slamch_(char *); - logical orgati; - real erretm, dtipsq, rhoinv; - - -/* -- 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 updated */ -/* eigenvalue of a positive symmetric rank-one modification to */ -/* a positive diagonal matrix whose entries are given as the squares */ -/* of the corresponding entries in the array d, and that */ - -/* 0 <= 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 ) * 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) REAL array, dimension ( N ) */ -/* The original eigenvalues. It is assumed that they are in */ -/* order, 0 <= D(I) < D(J) for I < J. */ - -/* Z (input) REAL array, dimension (N) */ -/* The components of the updating vector. */ - -/* DELTA (output) REAL array, dimension (N) */ -/* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th */ -/* component. If N = 1, then DELTA(1) = 1. The vector DELTA */ -/* contains the information necessary to construct the */ -/* (singular) eigenvectors. */ - -/* RHO (input) REAL */ -/* The scalar in the symmetric updating formula. */ - -/* SIGMA (output) REAL */ -/* The computed sigma_I, the I-th updated eigenvalue. */ - -/* WORK (workspace) REAL array, dimension (N) */ -/* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th */ -/* component. If N = 1, then WORK( 1 ) = 1. */ - -/* 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 Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. 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 */ - --work; - --delta; - --z__; - --d__; - - /* Function Body */ - *info = 0; - if (*n == 1) { - -/* Presumably, I=1 upon entry */ - - *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]); - delta[1] = 1.f; - work[1] = 1.f; - return 0; - } - if (*n == 2) { - slasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]); - return 0; - } - -/* Compute machine epsilon */ - - eps = slamch_("Epsilon"); - rhoinv = 1.f / *rho; - -/* The case I = N */ - - if (*i__ == *n) { - -/* Initialize some basic variables */ - - ii = *n - 1; - niter = 1; - -/* Calculate initial guess */ - - temp = *rho / 2.f; - -/* If ||Z||_2 is not one, then TEMP should be set to */ -/* RHO * ||Z||_2^2 / TWO */ - - temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp)); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*n] + temp1; - delta[j] = d__[j] - d__[*n] - temp1; -/* L10: */ - } - - psi = 0.f; - i__1 = *n - 2; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / (delta[j] * work[j]); -/* L20: */ - } - - c__ = rhoinv + psi; - w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[* - n] / (delta[*n] * work[*n]); - - if (w <= 0.f) { - temp1 = sqrt(d__[*n] * d__[*n] + *rho); - temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[* - n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] * - z__[*n] / *rho; - -/* The following TAU is to approximate */ -/* SIGMA_n^2 - D( N )*D( N ) */ - - if (c__ <= temp) { - tau = *rho; - } else { - delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); - a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[* - n]; - b = z__[*n] * z__[*n] * delsq; - if (a < 0.f) { - tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f); - } - } - -/* It can be proved that */ -/* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO */ - - } else { - delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); - a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; - b = z__[*n] * z__[*n] * delsq; - -/* The following TAU is to approximate */ -/* SIGMA_n^2 - D( N )*D( N ) */ - - if (a < 0.f) { - tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f); - } - -/* It can be proved that */ -/* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 */ - - } - -/* The following ETA is to approximate SIGMA_n - D( N ) */ - - eta = tau / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau)); - - *sigma = d__[*n] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - eta; - work[j] = d__[j] + d__[*i__] + eta; -/* L30: */ - } - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (delta[j] * work[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L40: */ - } - erretm = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / (delta[*n] * work[*n]); - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * ( - dpsi + dphi); - - w = rhoinv + phi + psi; - -/* Test for convergence */ - - if (dabs(w) <= eps * erretm) { - goto L240; - } - -/* Calculate the new step */ - - ++niter; - dtnsq1 = work[*n - 1] * delta[*n - 1]; - dtnsq = work[*n] * delta[*n]; - c__ = w - dtnsq1 * dpsi - dtnsq * dphi; - a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi); - b = dtnsq * dtnsq1 * w; - if (c__ < 0.f) { - c__ = dabs(c__); - } - if (c__ == 0.f) { - eta = *rho - *sigma * *sigma; - } else if (a >= 0.f) { - eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / ( - c__ * 2.f); - } else { - eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__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.f) { - eta = -w / (dpsi + dphi); - } - temp = eta - dtnsq; - if (temp > *rho) { - eta = *rho + dtnsq; - } - - tau += eta; - eta /= *sigma + sqrt(eta + *sigma * *sigma); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; - work[j] += eta; -/* L50: */ - } - - *sigma += eta; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L60: */ - } - erretm = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / (work[*n] * delta[*n]); - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * ( - dpsi + dphi); - - w = rhoinv + phi + psi; - -/* Main loop to update the values of the array DELTA */ - - iter = niter + 1; - - for (niter = iter; niter <= 20; ++niter) { - -/* Test for convergence */ - - if (dabs(w) <= eps * erretm) { - goto L240; - } - -/* Calculate the new step */ - - dtnsq1 = work[*n - 1] * delta[*n - 1]; - dtnsq = work[*n] * delta[*n]; - c__ = w - dtnsq1 * dpsi - dtnsq * dphi; - a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi); - b = dtnsq1 * dtnsq * w; - if (a >= 0.f) { - eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / - (c__ * 2.f); - } else { - eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__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.f) { - eta = -w / (dpsi + dphi); - } - temp = eta - dtnsq; - if (temp <= 0.f) { - eta /= 2.f; - } - - tau += eta; - eta /= *sigma + sqrt(eta + *sigma * *sigma); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; - work[j] += eta; -/* L70: */ - } - - *sigma += eta; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L80: */ - } - erretm = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / (work[*n] * delta[*n]); - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * - (dpsi + dphi); - - w = rhoinv + phi + psi; -/* L90: */ - } - -/* Return with INFO = 1, NITER = MAXIT and not converged */ - - *info = 1; - goto L240; - -/* End for the case I = N */ - - } else { - -/* The case for I < N */ - - niter = 1; - ip1 = *i__ + 1; - -/* Calculate initial guess */ - - delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]); - delsq2 = delsq / 2.f; - temp = delsq2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + delsq2)); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*i__] + temp; - delta[j] = d__[j] - d__[*i__] - temp; -/* L100: */ - } - - psi = 0.f; - i__1 = *i__ - 1; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / (work[j] * delta[j]); -/* L110: */ - } - - phi = 0.f; - i__1 = *i__ + 2; - for (j = *n; j >= i__1; --j) { - phi += z__[j] * z__[j] / (work[j] * delta[j]); -/* L120: */ - } - c__ = rhoinv + psi + phi; - w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[ - ip1] * z__[ip1] / (work[ip1] * delta[ip1]); - - if (w > 0.f) { - -/* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 */ - -/* We choose d(i) as origin. */ - - orgati = TRUE_; - sg2lb = 0.f; - sg2ub = delsq2; - a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; - b = z__[*i__] * z__[*i__] * delsq; - if (a > 0.f) { - tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__1)))); - } else { - tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / - (c__ * 2.f); - } - -/* TAU now is an estimation of SIGMA^2 - D( I )^2. The */ -/* following, however, is the corresponding estimation of */ -/* SIGMA - D( I ). */ - - eta = tau / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau)); - } else { - -/* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 */ - -/* We choose d(i+1) as origin. */ - - orgati = FALSE_; - sg2lb = -delsq2; - sg2ub = 0.f; - a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; - b = z__[ip1] * z__[ip1] * delsq; - if (a < 0.f) { - tau = b * 2.f / (a - sqrt((r__1 = a * a + b * 4.f * c__, dabs( - r__1)))); - } else { - tau = -(a + sqrt((r__1 = a * a + b * 4.f * c__, dabs(r__1)))) - / (c__ * 2.f); - } - -/* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The */ -/* following, however, is the corresponding estimation of */ -/* SIGMA - D( IP1 ). */ - - eta = tau / (d__[ip1] + sqrt((r__1 = d__[ip1] * d__[ip1] + tau, - dabs(r__1)))); - } - - if (orgati) { - ii = *i__; - *sigma = d__[*i__] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*i__] + eta; - delta[j] = d__[j] - d__[*i__] - eta; -/* L130: */ - } - } else { - ii = *i__ + 1; - *sigma = d__[ip1] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[ip1] + eta; - delta[j] = d__[j] - d__[ip1] - eta; -/* L140: */ - } - } - iim1 = ii - 1; - iip1 = ii + 1; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L150: */ - } - erretm = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.f; - phi = 0.f; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[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.f) { - swtch3 = TRUE_; - } - } else { - if (w > 0.f) { - swtch3 = TRUE_; - } - } - if (ii == 1 || ii == *n) { - swtch3 = FALSE_; - } - - temp = z__[ii] / (work[ii] * delta[ii]); - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w += temp; - erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f - + dabs(tau) * dw; - -/* Test for convergence */ - - if (dabs(w) <= eps * erretm) { - goto L240; - } - - if (w <= 0.f) { - sg2lb = dmax(sg2lb,tau); - } else { - sg2ub = dmin(sg2ub,tau); - } - -/* Calculate the new step */ - - ++niter; - if (! swtch3) { - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (orgati) { -/* Computing 2nd power */ - r__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (r__1 * r__1); - } else { -/* Computing 2nd power */ - r__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (r__1 * r__1); - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.f) { - if (a == 0.f) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + - dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + - dphi); - } - } - eta = b / a; - } else if (a <= 0.f) { - eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / - (c__ * 2.f); - } else { - eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs( - r__1)))); - } - } else { - -/* Interpolation using THREE most relevant poles */ - - dtiim = work[iim1] * delta[iim1]; - dtiip = work[iip1] * delta[iip1]; - temp = rhoinv + psi + phi; - if (orgati) { - temp1 = z__[iim1] / dtiim; - temp1 *= temp1; - c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * - (d__[iim1] + d__[iip1]) * temp1; - zz[0] = z__[iim1] * z__[iim1]; - if (dpsi < temp1) { - zz[2] = dtiip * dtiip * dphi; - } else { - zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); - } - } else { - temp1 = z__[iip1] / dtiip; - temp1 *= temp1; - c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * - (d__[iim1] + d__[iip1]) * temp1; - if (dphi < temp1) { - zz[0] = dtiim * dtiim * dpsi; - } else { - zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); - } - zz[2] = z__[iip1] * z__[iip1]; - } - zz[1] = z__[ii] * z__[ii]; - dd[0] = dtiim; - dd[1] = delta[ii] * work[ii]; - dd[2] = dtiip; - slaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); - if (*info != 0) { - goto L240; - } - } - -/* 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.f) { - eta = -w / dw; - } - if (orgati) { - temp1 = work[*i__] * delta[*i__]; - temp = eta - temp1; - } else { - temp1 = work[ip1] * delta[ip1]; - temp = eta - temp1; - } - if (temp > sg2ub || temp < sg2lb) { - if (w < 0.f) { - eta = (sg2ub - tau) / 2.f; - } else { - eta = (sg2lb - tau) / 2.f; - } - } - - tau += eta; - eta /= *sigma + sqrt(*sigma * *sigma + eta); - - prew = w; - - *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += eta; - delta[j] -= eta; -/* L170: */ - } - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L180: */ - } - erretm = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.f; - phi = 0.f; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L190: */ - } - - temp = z__[ii] / (work[ii] * delta[ii]); - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f - + dabs(tau) * dw; - - if (w <= 0.f) { - sg2lb = dmax(sg2lb,tau); - } else { - sg2ub = dmin(sg2ub,tau); - } - - swtch = FALSE_; - if (orgati) { - if (-w > dabs(prew) / 10.f) { - swtch = TRUE_; - } - } else { - if (w > dabs(prew) / 10.f) { - swtch = TRUE_; - } - } - -/* Main loop to update the values of the array DELTA and WORK */ - - iter = niter + 1; - - for (niter = iter; niter <= 20; ++niter) { - -/* Test for convergence */ - - if (dabs(w) <= eps * erretm) { - goto L240; - } - -/* Calculate the new step */ - - if (! swtch3) { - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (! swtch) { - if (orgati) { -/* Computing 2nd power */ - r__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (r__1 * r__1); - } else { -/* Computing 2nd power */ - r__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (r__1 * r__1); - } - } else { - temp = z__[ii] / (work[ii] * delta[ii]); - if (orgati) { - dpsi += temp * temp; - } else { - dphi += temp * temp; - } - c__ = w - dtisq * dpsi - dtipsq * dphi; - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.f) { - if (a == 0.f) { - if (! swtch) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * - (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * ( - dpsi + dphi); - } - } else { - a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi; - } - } - eta = b / a; - } else if (a <= 0.f) { - eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)) - )) / (c__ * 2.f); - } else { - eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, - dabs(r__1)))); - } - } else { - -/* Interpolation using THREE most relevant poles */ - - dtiim = work[iim1] * delta[iim1]; - dtiip = work[iip1] * delta[iip1]; - temp = rhoinv + psi + phi; - if (swtch) { - c__ = temp - dtiim * dpsi - dtiip * dphi; - zz[0] = dtiim * dtiim * dpsi; - zz[2] = dtiip * dtiip * dphi; - } else { - if (orgati) { - temp1 = z__[iim1] / dtiim; - temp1 *= temp1; - temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[ - iip1]) * temp1; - c__ = temp - dtiip * (dpsi + dphi) - temp2; - zz[0] = z__[iim1] * z__[iim1]; - if (dpsi < temp1) { - zz[2] = dtiip * dtiip * dphi; - } else { - zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); - } - } else { - temp1 = z__[iip1] / dtiip; - temp1 *= temp1; - temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[ - iip1]) * temp1; - c__ = temp - dtiim * (dpsi + dphi) - temp2; - if (dphi < temp1) { - zz[0] = dtiim * dtiim * dpsi; - } else { - zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); - } - zz[2] = z__[iip1] * z__[iip1]; - } - } - dd[0] = dtiim; - dd[1] = delta[ii] * work[ii]; - dd[2] = dtiip; - slaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); - if (*info != 0) { - goto L240; - } - } - -/* 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.f) { - eta = -w / dw; - } - if (orgati) { - temp1 = work[*i__] * delta[*i__]; - temp = eta - temp1; - } else { - temp1 = work[ip1] * delta[ip1]; - temp = eta - temp1; - } - if (temp > sg2ub || temp < sg2lb) { - if (w < 0.f) { - eta = (sg2ub - tau) / 2.f; - } else { - eta = (sg2lb - tau) / 2.f; - } - } - - tau += eta; - eta /= *sigma + sqrt(*sigma * *sigma + eta); - - *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += eta; - delta[j] -= eta; -/* L200: */ - } - - prew = w; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.f; - psi = 0.f; - erretm = 0.f; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L210: */ - } - erretm = dabs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.f; - phi = 0.f; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L220: */ - } - - temp = z__[ii] / (work[ii] * delta[ii]); - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * - 3.f + dabs(tau) * dw; - if (w * prew > 0.f && dabs(w) > dabs(prew) / 10.f) { - swtch = ! swtch; - } - - if (w <= 0.f) { - sg2lb = dmax(sg2lb,tau); - } else { - sg2ub = dmin(sg2ub,tau); - } - -/* L230: */ - } - -/* Return with INFO = 1, NITER = MAXIT and not converged */ - - *info = 1; - - } - -L240: - return 0; - -/* End of SLASD4 */ - -} /* slasd4_ */ diff --git a/3rdparty/lapack/slasd5.c b/3rdparty/lapack/slasd5.c deleted file mode 100644 index b8bdada..0000000 --- a/3rdparty/lapack/slasd5.c +++ /dev/null @@ -1,189 +0,0 @@ -/* slasd5.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 slasd5_(integer *i__, real *d__, real *z__, real *delta, - real *rho, real *dsigma, real *work) -{ - /* System generated locals */ - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real 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) REAL array, dimension (2) */ -/* The original eigenvalues. We assume 0 <= D(1) < D(2). */ - -/* Z (input) REAL array, dimension (2) */ -/* The components of the updating vector. */ - -/* DELTA (output) REAL 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) REAL */ -/* The scalar in the symmetric updating formula. */ - -/* DSIGMA (output) REAL */ -/* The computed sigma_I, the I-th updated eigenvalue. */ - -/* WORK (workspace) REAL 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.f * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.f) - z__[1] * - z__[1] / (d__[1] * 3.f + d__[2])) / del + 1.f; - if (w > 0.f) { - 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.f / (b + sqrt((r__1 = b * b - c__ * 4.f, dabs(r__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.f + 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.f) { - tau = c__ * -2.f / (b + sqrt(b * b + c__ * 4.f)); - } else { - tau = (b - sqrt(b * b + c__ * 4.f)) / 2.f; - } - -/* The following TAU is DSIGMA - D( 2 ) */ - - tau /= d__[2] + sqrt((r__1 = d__[2] * d__[2] + tau, dabs(r__1))); - *dsigma = d__[2] + tau; - delta[1] = -(del + tau); - delta[2] = -tau; - work[1] = d__[1] + tau + d__[2]; - work[2] = d__[2] * 2.f + 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.f) { - tau = (b + sqrt(b * b + c__ * 4.f)) / 2.f; - } else { - tau = c__ * 2.f / (-b + sqrt(b * b + c__ * 4.f)); - } - -/* 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.f + 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 SLASD5 */ - -} /* slasd5_ */ diff --git a/3rdparty/lapack/slasd6.c b/3rdparty/lapack/slasd6.c deleted file mode 100644 index 4ebc82e..0000000 --- a/3rdparty/lapack/slasd6.c +++ /dev/null @@ -1,364 +0,0 @@ -/* slasd6.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 real c_b7 = 1.f; -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int slasd6_(integer *icompq, integer *nl, integer *nr, - integer *sqre, real *d__, real *vf, real *vl, real *alpha, real *beta, - integer *idxq, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real * - difl, real *difr, real *z__, integer *k, real *c__, real *s, real * - work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, - poles_dim1, poles_offset, i__1; - real r__1, r__2; - - /* Local variables */ - integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), slasd7_(integer *, integer *, integer *, integer *, - integer *, real *, real *, real *, real *, real *, real *, real *, - real *, real *, real *, integer *, integer *, integer *, integer - *, integer *, integer *, integer *, real *, integer *, real *, - real *, integer *), slasd8_(integer *, integer *, real *, real *, - real *, real *, real *, real *, integer *, real *, real *, - integer *); - integer isigma; - extern /* Subroutine */ int xerbla_(char *, integer *), slascl_( - char *, integer *, integer *, real *, real *, integer *, integer * -, real *, integer *, integer *), slamrg_(integer *, - integer *, real *, integer *, integer *, integer *); - real orgnrm; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASD6 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, SLASD1, handles the case in which all singular */ -/* values and singular vectors of the bidiagonal matrix are desired. */ - -/* SLASD6 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 SLASD6. 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 SLASD7. */ - -/* The second stage consists of calculating the updated */ -/* singular values. This is done by finding the roots of the */ -/* secular equation via the routine SLASD4 (as called by SLASD8). */ -/* This routine also updates VF and VL and computes the distances */ -/* between the updated singular values and the old singular */ -/* values. */ - -/* SLASD6 is called from SLASDA. */ - -/* 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) REAL 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) REAL 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) REAL 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) REAL */ -/* Contains the diagonal element associated with the added row. */ - -/* BETA (input/output) REAL */ -/* 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) REAL 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) REAL 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) REAL 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) REAL 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 SLASD8 for details on DIFL and DIFR. */ - -/* Z (output) REAL 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) REAL */ -/* 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) REAL */ -/* 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) REAL 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_("SLASD6", &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 SLASD7 and SLASD8. */ - - isigma = 1; - iw = isigma + n; - ivfw = iw + m; - ivlw = ivfw + m; - - idx = 1; - idxc = idx + n; - idxp = idxc + n; - -/* Scale. */ - -/* Computing MAX */ - r__1 = dabs(*alpha), r__2 = dabs(*beta); - orgnrm = dmax(r__1,r__2); - d__[*nl + 1] = 0.f; - i__1 = n; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((r__1 = d__[i__], dabs(r__1)) > orgnrm) { - orgnrm = (r__1 = d__[i__], dabs(r__1)); - } -/* L10: */ - } - slascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info); - *alpha /= orgnrm; - *beta /= orgnrm; - -/* Sort and Deflate singular values. */ - - slasd7_(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. */ - - slasd8_(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) { - scopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1); - scopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1); - } - -/* Unscale. */ - - slascl_("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; - slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]); - - return 0; - -/* End of SLASD6 */ - -} /* slasd6_ */ diff --git a/3rdparty/lapack/slasd7.c b/3rdparty/lapack/slasd7.c deleted file mode 100644 index 5533633..0000000 --- a/3rdparty/lapack/slasd7.c +++ /dev/null @@ -1,516 +0,0 @@ -/* slasd7.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 slasd7_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *k, real *d__, real *z__, real *zw, real *vf, - real *vfw, real *vl, real *vlw, real *alpha, real *beta, real *dsigma, - integer *idx, integer *idxp, integer *idxq, integer *perm, integer * - givptr, integer *givcol, integer *ldgcol, real *givnum, integer * - ldgnum, real *c__, real *s, integer *info) -{ - /* System generated locals */ - integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1; - real r__1, r__2; - - /* Local variables */ - integer i__, j, m, n, k2; - real z1; - integer jp; - real eps, tau, tol; - integer nlp1, nlp2, idxi, idxj; - extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, - integer *, real *, real *); - integer idxjp, jprev; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - extern doublereal slapy2_(real *, real *), slamch_(char *); - extern /* Subroutine */ int xerbla_(char *, integer *), slamrg_( - integer *, integer *, real *, integer *, integer *, integer *); - real hlftol; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASD7 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. */ - -/* SLASD7 is called from SLASD6. */ - -/* 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) REAL 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) REAL array, dimension ( M ) */ -/* On exit Z contains the updating row vector in the secular */ -/* equation. */ - -/* ZW (workspace) REAL array, dimension ( M ) */ -/* Workspace for Z. */ - -/* VF (input/output) REAL 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) REAL array, dimension ( M ) */ -/* Workspace for VF. */ - -/* VL (input/output) REAL 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) REAL array, dimension ( M ) */ -/* Workspace for VL. */ - -/* ALPHA (input) REAL */ -/* Contains the diagonal element associated with the added row. */ - -/* BETA (input) REAL */ -/* Contains the off-diagonal element associated with the added */ -/* row. */ - -/* DSIGMA (output) REAL 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) REAL 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) REAL */ -/* 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) REAL */ -/* 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_("SLASD7", &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.f; - tau = vf[nlp1]; - for (i__ = *nl; i__ >= 1; --i__) { - z__[i__ + 1] = *alpha * vl[i__]; - vl[i__] = 0.f; - 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.f; -/* 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: */ - } - - slamrg_(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 = slamch_("Epsilon"); -/* Computing MAX */ - r__1 = dabs(*alpha), r__2 = dabs(*beta); - tol = dmax(r__1,r__2); -/* Computing MAX */ - r__2 = (r__1 = d__[n], dabs(r__1)); - tol = eps * 64.f * dmax(r__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 ((r__1 = z__[j], dabs(r__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 ((r__1 = z__[j], dabs(r__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - idxp[k2] = j; - } else { - -/* Check if singular values are close enough to allow deflation. */ - - if ((r__1 = d__[j] - d__[jprev], dabs(r__1)) <= tol) { - -/* Deflation is possible. */ - - *s = z__[jprev]; - *c__ = z__[j]; - -/* Find sqrt(a**2+b**2) without overflow or */ -/* destructive underflow. */ - - tau = slapy2_(c__, s); - z__[j] = tau; - z__[jprev] = 0.f; - *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; - } - srot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s); - srot_(&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; - scopy_(&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.f; - hlftol = tol / 2.f; - if (dabs(dsigma[2]) <= hlftol) { - dsigma[2] = hlftol; - } - if (m > n) { - z__[1] = slapy2_(&z1, &z__[m]); - if (z__[1] <= tol) { - *c__ = 1.f; - *s = 0.f; - z__[1] = tol; - } else { - *c__ = z1 / z__[1]; - *s = -z__[m] / z__[1]; - } - srot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s); - srot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s); - } else { - if (dabs(z1) <= tol) { - z__[1] = tol; - } else { - z__[1] = z1; - } - } - -/* Restore Z, VF, and VL. */ - - i__1 = *k - 1; - scopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1); - i__1 = n - 1; - scopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1); - i__1 = n - 1; - scopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1); - - return 0; - -/* End of SLASD7 */ - -} /* slasd7_ */ diff --git a/3rdparty/lapack/slasd8.c b/3rdparty/lapack/slasd8.c deleted file mode 100644 index 195498f..0000000 --- a/3rdparty/lapack/slasd8.c +++ /dev/null @@ -1,323 +0,0 @@ -/* slasd8.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 real c_b8 = 1.f; - -/* Subroutine */ int slasd8_(integer *icompq, integer *k, real *d__, real * - z__, real *vf, real *vl, real *difl, real *difr, integer *lddifr, - real *dsigma, real *work, integer *info) -{ - /* System generated locals */ - integer difr_dim1, difr_offset, i__1, i__2; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal), r_sign(real *, real *); - - /* Local variables */ - integer i__, j; - real dj, rho; - integer iwk1, iwk2, iwk3; - real temp; - extern doublereal sdot_(integer *, real *, integer *, real *, integer *); - integer iwk2i, iwk3i; - extern doublereal snrm2_(integer *, real *, integer *); - real diflj, difrj, dsigj; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - extern doublereal slamc3_(real *, real *); - extern /* Subroutine */ int slasd4_(integer *, integer *, real *, real *, - real *, real *, real *, real *, integer *), xerbla_(char *, - integer *); - real dsigjp; - extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, - real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *, - real *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* October 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASD8 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 SLASD4, 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. */ - -/* SLASD8 is called from SLASD6. */ - -/* 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 SLASD4. K >= 1. */ - -/* D (output) REAL array, dimension ( K ) */ -/* On output, D contains the updated singular values. */ - -/* Z (input/output) REAL 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) REAL 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) REAL 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) REAL array, dimension ( K ) */ -/* On exit, DIFL(I) = D(I) - DSIGMA(I). */ - -/* DIFR (output) REAL 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) REAL 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) REAL 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_("SLASD8", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*k == 1) { - d__[1] = dabs(z__[1]); - difl[1] = d__[1]; - if (*icompq == 1) { - difl[2] = 1.f; - difr[(difr_dim1 << 1) + 1] = 1.f; - } - 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__] = slamc3_(&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 = snrm2_(k, &z__[1], &c__1); - slascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info); - rho *= rho; - -/* Initialize WORK(IWK3). */ - - slaset_("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) { - slasd4_(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__) { - r__2 = sqrt((r__1 = work[iwk3i + i__], dabs(r__1))); - z__[i__] = r_sign(&r__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__] / (slamc3_(&dsigma[i__], &dsigj) - diflj) / ( - dsigma[i__] + dj); -/* L60: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work[i__] = z__[i__] / (slamc3_(&dsigma[i__], &dsigjp) + difrj) / - (dsigma[i__] + dj); -/* L70: */ - } - temp = snrm2_(k, &work[1], &c__1); - work[iwk2i + j] = sdot_(k, &work[1], &c__1, &vf[1], &c__1) / temp; - work[iwk3i + j] = sdot_(k, &work[1], &c__1, &vl[1], &c__1) / temp; - if (*icompq == 1) { - difr[j + (difr_dim1 << 1)] = temp; - } -/* L80: */ - } - - scopy_(k, &work[iwk2], &c__1, &vf[1], &c__1); - scopy_(k, &work[iwk3], &c__1, &vl[1], &c__1); - - return 0; - -/* End of SLASD8 */ - -} /* slasd8_ */ diff --git a/3rdparty/lapack/slasda.c b/3rdparty/lapack/slasda.c deleted file mode 100644 index daab1e0..0000000 --- a/3rdparty/lapack/slasda.c +++ /dev/null @@ -1,483 +0,0 @@ -/* slasda.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 real c_b11 = 0.f; -static real c_b12 = 1.f; -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int slasda_(integer *icompq, integer *smlsiz, integer *n, - integer *sqre, real *d__, real *e, real *u, integer *ldu, real *vt, - integer *k, real *difl, real *difr, real *z__, real *poles, integer * - givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum, - real *c__, real *s, real *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; - real beta; - integer idxq, nlvl; - real alpha; - integer inode, ndiml, ndimr, idxqi, itemp, sqrei; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), slasd6_(integer *, integer *, integer *, integer *, - real *, real *, real *, real *, real *, integer *, integer *, - integer *, integer *, integer *, real *, integer *, real *, real * -, real *, real *, integer *, real *, real *, real *, integer *, - integer *); - integer nwork1, nwork2; - extern /* Subroutine */ int xerbla_(char *, integer *), slasdq_( - char *, integer *, integer *, integer *, integer *, integer *, - real *, real *, real *, integer *, real *, integer *, real *, - integer *, real *, integer *), slasdt_(integer *, integer - *, integer *, integer *, integer *, integer *, integer *), - slaset_(char *, integer *, integer *, real *, real *, real *, - 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, SLASDA 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, SLASD0, 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) REAL 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) REAL array, dimension ( M-1 ) */ -/* Contains the subdiagonal entries of the bidiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* U (output) REAL 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) REAL 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) REAL array, dimension ( LDU, NLVL ), */ -/* where NLVL = floor(log_2 (N/SMLSIZ))). */ - -/* DIFR (output) REAL 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 SLASD8 for details. */ - -/* Z (output) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL array, dimension */ -/* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */ - -/* IWORK (workspace) INTEGER array, dimension (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_("SLASDA", &i__1); - return 0; - } - - m = *n + *sqre; - -/* If the input matrix is too small, call SLASDQ to find the SVD. */ - - if (*n <= *smlsiz) { - if (*icompq == 0) { - slasdq_("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 { - slasdq_("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; - - slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], - smlsiz); - -/* for the nodes on bottom level of the tree, solve */ -/* their subproblems by SLASDQ. */ - - 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) { - slaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp); - slasdq_("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; - scopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1); - scopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1); - } else { - slaset_("A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu); - slaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], - ldu); - slasdq_("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); - scopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1); - scopy_(&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) { - slaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp); - slasdq_("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; - scopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1); - scopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1); - } else { - slaset_("A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu); - slaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], - ldu); - slasdq_("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); - scopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1); - scopy_(&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) { - slasd6_(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; - slasd6_(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 SLASDA */ - -} /* slasda_ */ diff --git a/3rdparty/lapack/slasdq.c b/3rdparty/lapack/slasdq.c deleted file mode 100644 index 515aa96..0000000 --- a/3rdparty/lapack/slasdq.c +++ /dev/null @@ -1,379 +0,0 @@ -/* slasdq.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 slasdq_(char *uplo, integer *sqre, integer *n, integer * - ncvt, integer *nru, integer *ncc, real *d__, real *e, real *vt, - integer *ldvt, real *u, integer *ldu, real *c__, integer *ldc, real * - 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; - real r__, cs, sn; - integer np1, isub; - real smin; - integer sqre1; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int slasr_(char *, char *, char *, integer *, - integer *, real *, real *, real *, integer *); - integer iuplo; - extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, - integer *), xerbla_(char *, integer *), slartg_(real *, - real *, real *, real *, real *); - logical rotate; - extern /* Subroutine */ int sbdsqr_(char *, integer *, integer *, integer - *, integer *, real *, real *, real *, integer *, real *, integer * -, real *, integer *, real *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASDQ 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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_("SLASDQ", &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__) { - slartg_(&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: */ - } - slartg_(&d__[*n], &e[*n], &cs, &sn, &r__); - d__[*n] = r__; - e[*n] = 0.f; - if (rotate) { - work[*n] = cs; - work[*n + *n] = sn; - } - iuplo = 2; - sqre1 = 0; - -/* Update singular vectors if desired. */ - - if (*ncvt > 0) { - slasr_("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__) { - slartg_(&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) { - slartg_(&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) { - slasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[ - u_offset], ldu); - } else { - slasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[ - u_offset], ldu); - } - } - if (*ncc > 0) { - if (sqre1 == 0) { - slasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[ - c_offset], ldc); - } else { - slasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[ - c_offset], ldc); - } - } - } - -/* Call SBDSQR to compute the SVD of the reduced real */ -/* N-by-N upper bidiagonal matrix. */ - - sbdsqr_("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) { - sswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], - ldvt); - } - if (*nru > 0) { - sswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1] -, &c__1); - } - if (*ncc > 0) { - sswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc) - ; - } - } -/* L40: */ - } - - return 0; - -/* End of SLASDQ */ - -} /* slasdq_ */ diff --git a/3rdparty/lapack/slasdt.c b/3rdparty/lapack/slasdt.c deleted file mode 100644 index 2ceb0bb..0000000 --- a/3rdparty/lapack/slasdt.c +++ /dev/null @@ -1,136 +0,0 @@ -/* slasdt.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 slasdt_(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; - real 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 */ -/* ======= */ - -/* SLASDT 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((real) maxn / (real) (*msub + 1)) / log(2.f); - *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 SLASDT */ - -} /* slasdt_ */ diff --git a/3rdparty/lapack/slaset.c b/3rdparty/lapack/slaset.c deleted file mode 100644 index 55c571c..0000000 --- a/3rdparty/lapack/slaset.c +++ /dev/null @@ -1,152 +0,0 @@ -/* slaset.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 slaset_(char *uplo, integer *m, integer *n, real *alpha, - real *beta, real *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 */ -/* ======= */ - -/* SLASET 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) REAL */ -/* The constant to which the offdiagonal elements are to be set. */ - -/* BETA (input) REAL */ -/* The constant to which the diagonal elements are to be set. */ - -/* A (input/output) REAL 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 SLASET */ - -} /* slaset_ */ diff --git a/3rdparty/lapack/slasq1.c b/3rdparty/lapack/slasq1.c deleted file mode 100644 index 6b3ac67..0000000 --- a/3rdparty/lapack/slasq1.c +++ /dev/null @@ -1,216 +0,0 @@ -/* slasq1.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 slasq1_(integer *n, real *d__, real *e, real *work, - integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - real r__1, r__2, r__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__; - real eps; - extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *) - ; - real scale; - integer iinfo; - real sigmn, sigmx; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), slasq2_(integer *, real *, integer *); - extern doublereal slamch_(char *); - real safmin; - extern /* Subroutine */ int xerbla_(char *, integer *), slascl_( - char *, integer *, integer *, real *, real *, integer *, integer * -, real *, integer *, integer *), slasrt_(char *, integer * -, real *, 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 */ -/* ======= */ - -/* SLASQ1 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) REAL 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) REAL 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) REAL 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_("SLASQ1", &i__1); - return 0; - } else if (*n == 0) { - return 0; - } else if (*n == 1) { - d__[1] = dabs(d__[1]); - return 0; - } else if (*n == 2) { - slas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); - d__[1] = sigmx; - d__[2] = sigmn; - return 0; - } - -/* Estimate the largest singular value. */ - - sigmx = 0.f; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = (r__1 = d__[i__], dabs(r__1)); -/* Computing MAX */ - r__2 = sigmx, r__3 = (r__1 = e[i__], dabs(r__1)); - sigmx = dmax(r__2,r__3); -/* L10: */ - } - d__[*n] = (r__1 = d__[*n], dabs(r__1)); - -/* Early return if SIGMX is zero (matrix is already diagonal). */ - - if (sigmx == 0.f) { - slasrt_("D", n, &d__[1], &iinfo); - return 0; - } - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - r__1 = sigmx, r__2 = d__[i__]; - sigmx = dmax(r__1,r__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 = slamch_("Precision"); - safmin = slamch_("Safe minimum"); - scale = sqrt(eps / safmin); - scopy_(n, &d__[1], &c__1, &work[1], &c__2); - i__1 = *n - 1; - scopy_(&i__1, &e[1], &c__1, &work[2], &c__2); - i__1 = (*n << 1) - 1; - i__2 = (*n << 1) - 1; - slascl_("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 */ - r__1 = work[i__]; - work[i__] = r__1 * r__1; -/* L30: */ - } - work[*n * 2] = 0.f; - - slasq2_(n, &work[1], info); - - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = sqrt(work[i__]); -/* L40: */ - } - slascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & - iinfo); - } - - return 0; - -/* End of SLASQ1 */ - -} /* slasq1_ */ diff --git a/3rdparty/lapack/slasq2.c b/3rdparty/lapack/slasq2.c deleted file mode 100644 index b6b34b3..0000000 --- a/3rdparty/lapack/slasq2.c +++ /dev/null @@ -1,599 +0,0 @@ -/* slasq2.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 slasq2_(integer *n, real *z__, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real d__, e, g; - integer k; - real s, t; - integer i0, i4, n0; - real dn; - integer pp; - real dn1, dn2, dee, eps, tau, tol; - integer ipn4; - real tol2; - logical ieee; - integer nbig; - real dmin__, emin, emax; - integer kmin, ndiv, iter; - real qmin, temp, qmax, zmax; - integer splt; - real dmin1, dmin2; - integer nfail; - real desig, trace, sigma; - integer iinfo, ttype; - extern /* Subroutine */ int slasq3_(integer *, integer *, real *, integer - *, real *, real *, real *, real *, integer *, integer *, integer * -, logical *, integer *, real *, real *, real *, real *, real *, - real *, real *); - real deemin; - extern doublereal slamch_(char *); - integer iwhila, iwhilb; - real oldemn, safmin; - extern /* Subroutine */ int xerbla_(char *, integer *), slasrt_( - char *, integer *, real *, 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 */ -/* ======= */ - -/* SLASQ2 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 : SLASQ2 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 SLASQ3. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of rows and columns in the matrix. N >= 0. */ - -/* Z (input/output) REAL 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 SLASQ2 is not called by SLASQ1) */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - *info = 0; - eps = slamch_("Precision"); - safmin = slamch_("Safe minimum"); - tol = eps * 100.f; -/* Computing 2nd power */ - r__1 = tol; - tol2 = r__1 * r__1; - - if (*n < 0) { - *info = -1; - xerbla_("SLASQ2", &c__1); - return 0; - } else if (*n == 0) { - return 0; - } else if (*n == 1) { - -/* 1-by-1 case. */ - - if (z__[1] < 0.f) { - *info = -201; - xerbla_("SLASQ2", &c__2); - } - return 0; - } else if (*n == 2) { - -/* 2-by-2 case. */ - - if (z__[2] < 0.f || z__[3] < 0.f) { - *info = -2; - xerbla_("SLASQ2", &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]) * .5f; - s = z__[3] * (z__[2] / t); - if (s <= t) { - s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.f) + 1.f))); - } 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.f; - emin = z__[2]; - qmax = 0.f; - zmax = 0.f; - d__ = 0.f; - e = 0.f; - - i__1 = *n - 1 << 1; - for (k = 1; k <= i__1; k += 2) { - if (z__[k] < 0.f) { - *info = -(k + 200); - xerbla_("SLASQ2", &c__2); - return 0; - } else if (z__[k + 1] < 0.f) { - *info = -(k + 201); - xerbla_("SLASQ2", &c__2); - return 0; - } - d__ += z__[k]; - e += z__[k + 1]; -/* Computing MAX */ - r__1 = qmax, r__2 = z__[k]; - qmax = dmax(r__1,r__2); -/* Computing MIN */ - r__1 = emin, r__2 = z__[k + 1]; - emin = dmin(r__1,r__2); -/* Computing MAX */ - r__1 = max(qmax,zmax), r__2 = z__[k + 1]; - zmax = dmax(r__1,r__2); -/* L10: */ - } - if (z__[(*n << 1) - 1] < 0.f) { - *info = -((*n << 1) + 199); - xerbla_("SLASQ2", &c__2); - return 0; - } - d__ += z__[(*n << 1) - 1]; -/* Computing MAX */ - r__1 = qmax, r__2 = z__[(*n << 1) - 1]; - qmax = dmax(r__1,r__2); - zmax = dmax(qmax,zmax); - -/* Check for diagonality. */ - - if (e == 0.f) { - i__1 = *n; - for (k = 2; k <= i__1; ++k) { - z__[k] = z__[(k << 1) - 1]; -/* L20: */ - } - slasrt_("D", n, &z__[1], &iinfo); - z__[(*n << 1) - 1] = d__; - return 0; - } - - trace = d__ + e; - -/* Check for zero data. */ - - if (trace == 0.f) { - z__[(*n << 1) - 1] = 0.f; - return 0; - } - -/* Check whether the machine is IEEE conformable. */ - -/* IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. */ -/* $ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 */ - -/* [11/15/2008] The case IEEE=.TRUE. has a problem in single precision with */ -/* some the test matrices of type 16. The double precision code is fine. */ - - ieee = FALSE_; - -/* 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.f; - z__[(k << 1) - 1] = z__[k]; - z__[(k << 1) - 2] = 0.f; - z__[(k << 1) - 3] = z__[k - 1]; -/* L30: */ - } - - i0 = 1; - n0 = *n; - -/* Reverse the qd-array, if warranted. */ - - if (z__[(i0 << 2) - 3] * 1.5f < 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.f; - 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.f; - z__[i4 - (pp << 1) - 2] = d__; - z__[i4 - (pp << 1)] = 0.f; - 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 */ - r__1 = emin, r__2 = z__[i4 - (pp << 1)]; - emin = dmin(r__1,r__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 */ - r__1 = qmax, r__2 = z__[i4]; - qmax = dmax(r__1,r__2); -/* L70: */ - } - -/* Prepare for the next iteration on K. */ - - pp = 1 - pp; -/* L80: */ - } - -/* Initialise variables to pass to SLASQ3. */ - - ttype = 0; - dmin1 = 0.f; - dmin2 = 0.f; - dn = 0.f; - dn1 = 0.f; - dn2 = 0.f; - g = 0.f; - tau = 0.f; - - 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.f; - if (n0 == *n) { - sigma = 0.f; - } else { - sigma = -z__[(n0 << 2) - 1]; - } - if (sigma < 0.f) { - *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.f; - if (n0 > i0) { - emin = (r__1 = z__[(n0 << 2) - 5], dabs(r__1)); - } else { - emin = 0.f; - } - qmin = z__[(n0 << 2) - 3]; - qmax = qmin; - for (i4 = n0 << 2; i4 >= 8; i4 += -4) { - if (z__[i4 - 5] <= 0.f) { - goto L100; - } - if (qmin >= emax * 4.f) { -/* Computing MIN */ - r__1 = qmin, r__2 = z__[i4 - 3]; - qmin = dmin(r__1,r__2); -/* Computing MAX */ - r__1 = emax, r__2 = z__[i4 - 5]; - emax = dmax(r__1,r__2); - } -/* Computing MAX */ - r__1 = qmax, r__2 = z__[i4 - 7] + z__[i4 - 5]; - qmax = dmax(r__1,r__2); -/* Computing MIN */ - r__1 = emin, r__2 = z__[i4 - 5]; - emin = dmin(r__1,r__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] * - .5f) { - 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 */ - r__1 = 0.f, r__2 = qmin - sqrt(qmin) * 2.f * sqrt(emax); - dmin__ = -dmax(r__1,r__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 SLASQ3 */ -/* 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. */ - - slasq3_(&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.f; - emin = z__[i4 + 3]; - oldemn = z__[i4 + 4]; - } else { -/* Computing MAX */ - r__1 = qmax, r__2 = z__[i4 + 1]; - qmax = dmax(r__1,r__2); -/* Computing MIN */ - r__1 = emin, r__2 = z__[i4 - 1]; - emin = dmin(r__1,r__2); -/* Computing MIN */ - r__1 = oldemn, r__2 = z__[i4]; - oldemn = dmin(r__1,r__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. */ - - slasrt_("D", n, &z__[1], &iinfo); - - e = 0.f; - 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] = (real) iter; -/* Computing 2nd power */ - i__1 = *n; - z__[(*n << 1) + 4] = (real) ndiv / (real) (i__1 * i__1); - z__[(*n << 1) + 5] = nfail * 100.f / (real) iter; - return 0; - -/* End of SLASQ2 */ - -} /* slasq2_ */ diff --git a/3rdparty/lapack/slasq3.c b/3rdparty/lapack/slasq3.c deleted file mode 100644 index 2c3452a..0000000 --- a/3rdparty/lapack/slasq3.c +++ /dev/null @@ -1,346 +0,0 @@ -/* slasq3.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 slasq3_(integer *i0, integer *n0, real *z__, integer *pp, - real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail, - integer *iter, integer *ndiv, logical *ieee, integer *ttype, real * - dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real * - tau) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real s, t; - integer j4, nn; - real eps, tol; - integer n0in, ipn4; - real tol2, temp; - extern /* Subroutine */ int slasq4_(integer *, integer *, real *, integer - *, integer *, real *, real *, real *, real *, real *, real *, - real *, integer *, real *), slasq5_(integer *, integer *, real *, - integer *, real *, real *, real *, real *, real *, real *, real *, - logical *), slasq6_(integer *, integer *, real *, integer *, - real *, real *, real *, real *, real *, real *); - extern doublereal slamch_(char *); - extern logical sisnan_(real *); - - -/* -- 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 */ -/* ======= */ - -/* SLASQ3 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) REAL 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) REAL */ -/* Minimum value of d. */ - -/* SIGMA (output) REAL */ -/* Sum of shifts used in current segment. */ - -/* DESIG (input/output) REAL */ -/* Lower order part of SIGMA */ - -/* QMAX (input) REAL */ -/* 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 SLASQ5). */ - -/* TTYPE (input/output) INTEGER */ -/* Shift type. */ - -/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) REAL */ -/* These are passed as arguments in order to save their values */ -/* between calls to SLASQ3. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Function .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - n0in = *n0; - eps = slamch_("Precision"); - tol = eps * 100.f; -/* Computing 2nd power */ - r__1 = tol; - tol2 = r__1 * r__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]) * .5f; - s = z__[nn - 3] * (z__[nn - 5] / t); - if (s <= t) { - s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.f) + 1.f))); - } 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.f || *n0 < n0in) { - if (z__[(*i0 << 2) + *pp - 3] * 1.5f < 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 */ - r__1 = *dmin2, r__2 = z__[(*n0 << 2) + *pp - 1]; - *dmin2 = dmin(r__1,r__2); -/* Computing MIN */ - r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*i0 << 2) + *pp - 1] - , r__1 = min(r__1,r__2), r__2 = z__[(*i0 << 2) + *pp + 3]; - z__[(*n0 << 2) + *pp - 1] = dmin(r__1,r__2); -/* Computing MIN */ - r__1 = z__[(*n0 << 2) - *pp], r__2 = z__[(*i0 << 2) - *pp], r__1 = - min(r__1,r__2), r__2 = z__[(*i0 << 2) - *pp + 4]; - z__[(*n0 << 2) - *pp] = dmin(r__1,r__2); -/* Computing MAX */ - r__1 = *qmax, r__2 = z__[(*i0 << 2) + *pp - 3], r__1 = max(r__1, - r__2), r__2 = z__[(*i0 << 2) + *pp + 1]; - *qmax = dmax(r__1,r__2); - *dmin__ = -0.f; - } - } - -/* Choose a shift. */ - - slasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, - tau, ttype, g); - -/* Call dqds until DMIN > 0. */ - -L70: - - slasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2, - ieee); - - *ndiv += *n0 - *i0 + 2; - ++(*iter); - -/* Check status. */ - - if (*dmin__ >= 0.f && *dmin1 > 0.f) { - -/* Success. */ - - goto L90; - - } else if (*dmin__ < 0.f && *dmin1 > 0.f && z__[(*n0 - 1 << 2) - *pp] < - tol * (*sigma + *dn1) && dabs(*dn) < tol * *sigma) { - -/* Convergence hidden by negative DN. */ - - z__[(*n0 - 1 << 2) - *pp + 2] = 0.f; - *dmin__ = 0.f; - goto L90; - } else if (*dmin__ < 0.f) { - -/* TAU too big. Select new TAU and try again. */ - - ++(*nfail); - if (*ttype < -22) { - -/* Failed twice. Play it safe. */ - - *tau = 0.f; - } else if (*dmin1 > 0.f) { - -/* Late failure. Gives excellent shift. */ - - *tau = (*tau + *dmin__) * (1.f - eps * 2.f); - *ttype += -11; - } else { - -/* Early failure. Divide by 4. */ - - *tau *= .25f; - *ttype += -12; - } - goto L70; - } else if (sisnan_(dmin__)) { - -/* NaN. */ - - if (*tau == 0.f) { - goto L80; - } else { - *tau = 0.f; - goto L70; - } - } else { - -/* Possible underflow. Play it safe. */ - - goto L80; - } - -/* Risk of underflow. */ - -L80: - slasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2); - *ndiv += *n0 - *i0 + 2; - ++(*iter); - *tau = 0.f; - -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 SLASQ3 */ - -} /* slasq3_ */ diff --git a/3rdparty/lapack/slasq4.c b/3rdparty/lapack/slasq4.c deleted file mode 100644 index b7ad1b8..0000000 --- a/3rdparty/lapack/slasq4.c +++ /dev/null @@ -1,402 +0,0 @@ -/* slasq4.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 slasq4_(integer *i0, integer *n0, real *z__, integer *pp, - integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn, - real *dn1, real *dn2, real *tau, integer *ttype, real *g) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - real s, a2, b1, b2; - integer i4, nn, np; - real 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 */ -/* ======= */ - -/* SLASQ4 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) REAL 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) REAL */ -/* Minimum value of d. */ - -/* DMIN1 (input) REAL */ -/* Minimum value of d, excluding D( N0 ). */ - -/* DMIN2 (input) REAL */ -/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ - -/* DN (input) REAL */ -/* d(N) */ - -/* DN1 (input) REAL */ -/* d(N-1) */ - -/* DN2 (input) REAL */ -/* d(N-2) */ - -/* TAU (output) REAL */ -/* 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 SLASQ4. */ - -/* 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.f) { - *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 * .25f; - if (gap2 > 0.f && gap2 > b2) { - gap1 = a2 - *dn - b2 / gap2 * b2; - } else { - gap1 = a2 - *dn - (b1 + b2); - } - if (gap1 > 0.f && gap1 > b1) { -/* Computing MAX */ - r__1 = *dn - b1 / gap1 * b1, r__2 = *dmin__ * .5f; - s = dmax(r__1,r__2); - *ttype = -2; - } else { - s = 0.f; - if (*dn > b1) { - s = *dn - b1; - } - if (a2 > b1 + b2) { -/* Computing MIN */ - r__1 = s, r__2 = a2 - (b1 + b2); - s = dmin(r__1,r__2); - } -/* Computing MAX */ - r__1 = s, r__2 = *dmin__ * .333f; - s = dmax(r__1,r__2); - *ttype = -3; - } - } else { - -/* Case 4. */ - - *ttype = -4; - s = *dmin__ * .25f; - if (*dmin__ == *dn) { - gam = *dn; - a2 = 0.f; - 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.f) { - goto L20; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (dmax(b2,b1) * 100.f < a2 || .563f < a2) { - goto L20; - } -/* L10: */ - } -L20: - a2 *= 1.05f; - -/* Rayleigh quotient residual bound. */ - - if (a2 < .563f) { - s = gam * (1.f - sqrt(a2)) / (a2 + 1.f); - } - } - } else if (*dmin__ == *dn2) { - -/* Case 5. */ - - *ttype = -5; - s = *dmin__ * .25f; - -/* 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.f); - -/* 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.f) { - goto L40; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (dmax(b2,b1) * 100.f < a2 || .563f < a2) { - goto L40; - } -/* L30: */ - } -L40: - a2 *= 1.05f; - } - - if (a2 < .563f) { - s = gam * (1.f - sqrt(a2)) / (a2 + 1.f); - } - } else { - -/* Case 6, no information to guide us. */ - - if (*ttype == -6) { - *g += (1.f - *g) * .333f; - } else if (*ttype == -18) { - *g = .083250000000000005f; - } else { - *g = .25f; - } - 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 * .333f; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.f) { - 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 (dmax(b1,a2) * 100.f < b2) { - goto L60; - } -/* L50: */ - } -L60: - b2 = sqrt(b2 * 1.05f); -/* Computing 2nd power */ - r__1 = b2; - a2 = *dmin1 / (r__1 * r__1 + 1.f); - gap2 = *dmin2 * .5f - a2; - if (gap2 > 0.f && gap2 > b2 * a2) { -/* Computing MAX */ - r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2); - s = dmax(r__1,r__2); - } else { -/* Computing MAX */ - r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f); - s = dmax(r__1,r__2); - *ttype = -8; - } - } else { - -/* Case 9. */ - - s = *dmin1 * .25f; - if (*dmin1 == *dn1) { - s = *dmin1 * .5f; - } - *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.f < z__[nn - 7]) { - *ttype = -10; - s = *dmin2 * .333f; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.f) { - 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.f < b2) { - goto L80; - } -/* L70: */ - } -L80: - b2 = sqrt(b2 * 1.05f); -/* Computing 2nd power */ - r__1 = b2; - a2 = *dmin2 / (r__1 * r__1 + 1.f); - gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ - nn - 9]) - a2; - if (gap2 > 0.f && gap2 > b2 * a2) { -/* Computing MAX */ - r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2); - s = dmax(r__1,r__2); - } else { -/* Computing MAX */ - r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f); - s = dmax(r__1,r__2); - } - } else { - s = *dmin2 * .25f; - *ttype = -11; - } - } else if (*n0in > *n0 + 2) { - -/* Case 12, more than two eigenvalues deflated. No information. */ - - s = 0.f; - *ttype = -12; - } - - *tau = s; - return 0; - -/* End of SLASQ4 */ - -} /* slasq4_ */ diff --git a/3rdparty/lapack/slasq5.c b/3rdparty/lapack/slasq5.c deleted file mode 100644 index 72f27d4..0000000 --- a/3rdparty/lapack/slasq5.c +++ /dev/null @@ -1,239 +0,0 @@ -/* slasq5.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 slasq5_(integer *i0, integer *n0, real *z__, integer *pp, - real *tau, real *dmin__, real *dmin1, real *dmin2, real *dn, real * - dnm1, real *dnm2, logical *ieee) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Local variables */ - real d__; - integer j4, j4p2; - real 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 */ -/* ======= */ - -/* SLASQ5 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) REAL 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) REAL */ -/* This is the shift. */ - -/* DMIN (output) REAL */ -/* Minimum value of d. */ - -/* DMIN1 (output) REAL */ -/* Minimum value of d, excluding D( N0 ). */ - -/* DMIN2 (output) REAL */ -/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ - -/* DN (output) REAL */ -/* d(N0), the last value of d. */ - -/* DNM1 (output) REAL */ -/* d(N0-1). */ - -/* DNM2 (output) REAL */ -/* 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__ = dmin(*dmin__,d__); - z__[j4] = z__[j4 - 1] * temp; -/* Computing MIN */ - r__1 = z__[j4]; - emin = dmin(r__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__ = dmin(*dmin__,d__); - z__[j4 - 1] = z__[j4] * temp; -/* Computing MIN */ - r__1 = z__[j4 - 1]; - emin = dmin(r__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__ = dmin(*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__ = dmin(*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.f) { - return 0; - } else { - z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); - d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; - } - *dmin__ = dmin(*dmin__,d__); -/* Computing MIN */ - r__1 = emin, r__2 = z__[j4]; - emin = dmin(r__1,r__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.f) { - return 0; - } else { - z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); - d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; - } - *dmin__ = dmin(*dmin__,d__); -/* Computing MIN */ - r__1 = emin, r__2 = z__[j4 - 1]; - emin = dmin(r__1,r__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.f) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - } - *dmin__ = dmin(*dmin__,*dnm1); - - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - if (*dnm1 < 0.f) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - } - *dmin__ = dmin(*dmin__,*dn); - - } - - z__[j4 + 2] = *dn; - z__[(*n0 << 2) - *pp] = emin; - return 0; - -/* End of SLASQ5 */ - -} /* slasq5_ */ diff --git a/3rdparty/lapack/slasq6.c b/3rdparty/lapack/slasq6.c deleted file mode 100644 index c3dc46f..0000000 --- a/3rdparty/lapack/slasq6.c +++ /dev/null @@ -1,212 +0,0 @@ -/* slasq6.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 slasq6_(integer *i0, integer *n0, real *z__, integer *pp, - real *dmin__, real *dmin1, real *dmin2, real *dn, real *dnm1, real * - dnm2) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - - /* Local variables */ - real d__; - integer j4, j4p2; - real emin, temp; - extern doublereal slamch_(char *); - real 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 */ -/* ======= */ - -/* SLASQ6 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) REAL 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) REAL */ -/* Minimum value of d. */ - -/* DMIN1 (output) REAL */ -/* Minimum value of d, excluding D( N0 ). */ - -/* DMIN2 (output) REAL */ -/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ - -/* DN (output) REAL */ -/* d(N0), the last value of d. */ - -/* DNM1 (output) REAL */ -/* d(N0-1). */ - -/* DNM2 (output) REAL */ -/* 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 = slamch_("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.f) { - z__[j4] = 0.f; - d__ = z__[j4 + 1]; - *dmin__ = d__; - emin = 0.f; - } 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__ = dmin(*dmin__,d__); -/* Computing MIN */ - r__1 = emin, r__2 = z__[j4]; - emin = dmin(r__1,r__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.f) { - z__[j4 - 1] = 0.f; - d__ = z__[j4 + 2]; - *dmin__ = d__; - emin = 0.f; - } 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__ = dmin(*dmin__,d__); -/* Computing MIN */ - r__1 = emin, r__2 = z__[j4 - 1]; - emin = dmin(r__1,r__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.f) { - z__[j4] = 0.f; - *dnm1 = z__[j4p2 + 2]; - *dmin__ = *dnm1; - emin = 0.f; - } 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__ = dmin(*dmin__,*dnm1); - - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - if (z__[j4 - 2] == 0.f) { - z__[j4] = 0.f; - *dn = z__[j4p2 + 2]; - *dmin__ = *dn; - emin = 0.f; - } 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__ = dmin(*dmin__,*dn); - - z__[j4 + 2] = *dn; - z__[(*n0 << 2) - *pp] = emin; - return 0; - -/* End of SLASQ6 */ - -} /* slasq6_ */ diff --git a/3rdparty/lapack/slasr_custom.c b/3rdparty/lapack/slasr_custom.c deleted file mode 100644 index 458ced7..0000000 --- a/3rdparty/lapack/slasr_custom.c +++ /dev/null @@ -1,452 +0,0 @@ -/* slasr.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 slasr_(char *side, char *pivot, char *direct, integer *m, - integer *n, real *c__, real *s, real *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, info; - real temp; - extern logical lsame_(char *, char *); - real 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 */ -/* ======= */ - -/* SLASR 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) REAL array, dimension */ -/* (M-1) if SIDE = 'L' */ -/* (N-1) if SIDE = 'R' */ -/* The cosines c(k) of the plane rotations. */ - -/* S (input) REAL 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) REAL 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_("SLASR ", &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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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.f || stemp != 0.f) { - 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 SLASR */ - -} /* slasr_ */ diff --git a/3rdparty/lapack/slasrt.c b/3rdparty/lapack/slasrt.c deleted file mode 100644 index 36c6553..0000000 --- a/3rdparty/lapack/slasrt.c +++ /dev/null @@ -1,285 +0,0 @@ -/* slasrt.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 slasrt_(char *id, integer *n, real *d__, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j; - real d1, d2, d3; - integer dir; - real tmp; - integer endd; - extern logical lsame_(char *, char *); - integer stack[64] /* was [2][32] */; - real dmnmx; - integer start; - extern /* Subroutine */ int xerbla_(char *, integer *); - integer stkpnt; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Sort the numbers in D in increasing order (if ID = 'I') or */ -/* in decreasing order (if ID = 'D' ). */ - -/* Use Quick Sort, reverting to Insertion sort on arrays of */ -/* size <= 20. Dimension of STACK limits N to about 2**32. */ - -/* Arguments */ -/* ========= */ - -/* ID (input) CHARACTER*1 */ -/* = 'I': sort D in increasing order; */ -/* = 'D': sort D in decreasing order. */ - -/* N (input) INTEGER */ -/* The length of the array D. */ - -/* D (input/output) REAL array, dimension (N) */ -/* On entry, the array to be sorted. */ -/* On exit, D has been sorted into increasing order */ -/* (D(1) <= ... <= D(N) ) or into decreasing order */ -/* (D(1) >= ... >= D(N) ), depending on ID. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input paramters. */ - - /* Parameter adjustments */ - --d__; - - /* Function Body */ - *info = 0; - dir = -1; - if (lsame_(id, "D")) { - dir = 0; - } else if (lsame_(id, "I")) { - dir = 1; - } - if (dir == -1) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SLASRT", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 1) { - return 0; - } - - stkpnt = 1; - stack[0] = 1; - stack[1] = *n; -L10: - start = stack[(stkpnt << 1) - 2]; - endd = stack[(stkpnt << 1) - 1]; - --stkpnt; - if (endd - start <= 20 && endd - start > 0) { - -/* Do Insertion sort on D( START:ENDD ) */ - - if (dir == 0) { - -/* Sort into decreasing order */ - - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] > d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L30; - } -/* L20: */ - } -L30: - ; - } - - } else { - -/* Sort into increasing order */ - - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] < d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L50; - } -/* L40: */ - } -L50: - ; - } - - } - - } else if (endd - start > 20) { - -/* Partition D( START:ENDD ) and stack parts, largest one first */ - -/* Choose partition entry as median of 3 */ - - d1 = d__[start]; - d2 = d__[endd]; - i__ = (start + endd) / 2; - d3 = d__[i__]; - if (d1 < d2) { - if (d3 < d1) { - dmnmx = d1; - } else if (d3 < d2) { - dmnmx = d3; - } else { - dmnmx = d2; - } - } else { - if (d3 < d2) { - dmnmx = d2; - } else if (d3 < d1) { - dmnmx = d3; - } else { - dmnmx = d1; - } - } - - if (dir == 0) { - -/* Sort into decreasing order */ - - i__ = start - 1; - j = endd + 1; -L60: -L70: - --j; - if (d__[j] < dmnmx) { - goto L70; - } -L80: - ++i__; - if (d__[i__] > dmnmx) { - goto L80; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L60; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - } else { - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - } - } else { - -/* Sort into increasing order */ - - i__ = start - 1; - j = endd + 1; -L90: -L100: - --j; - if (d__[j] > dmnmx) { - goto L100; - } -L110: - ++i__; - if (d__[i__] < dmnmx) { - goto L110; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L90; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - } else { - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - } - } - } - if (stkpnt > 0) { - goto L10; - } - return 0; - -/* End of SLASRT */ - -} /* slasrt_ */ diff --git a/3rdparty/lapack/slassq.c b/3rdparty/lapack/slassq.c deleted file mode 100644 index 4a36f2b..0000000 --- a/3rdparty/lapack/slassq.c +++ /dev/null @@ -1,116 +0,0 @@ -/* slassq.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 slassq_(integer *n, real *x, integer *incx, real *scale, - real *sumsq) -{ - /* System generated locals */ - integer i__1, i__2; - real r__1; - - /* Local variables */ - integer ix; - real absxi; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASSQ returns the values scl and smsq such that */ - -/* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */ - -/* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */ -/* assumed to be non-negative and scl returns the value */ - -/* scl = max( scale, abs( x( i ) ) ). */ - -/* scale and sumsq must be supplied in SCALE and SUMSQ and */ -/* scl and smsq are overwritten on SCALE and SUMSQ respectively. */ - -/* The routine makes only one pass through the vector x. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of elements to be used from the vector X. */ - -/* X (input) REAL array, dimension (N) */ -/* The vector for which a scaled sum of squares is computed. */ -/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */ - -/* INCX (input) INTEGER */ -/* The increment between successive values of the vector X. */ -/* INCX > 0. */ - -/* SCALE (input/output) REAL */ -/* On entry, the value scale in the equation above. */ -/* On exit, SCALE is overwritten with scl , the scaling factor */ -/* for the sum of squares. */ - -/* SUMSQ (input/output) REAL */ -/* On entry, the value sumsq in the equation above. */ -/* On exit, SUMSQ is overwritten with smsq , the basic sum of */ -/* squares from which scl has been factored out. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n > 0) { - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.f) { - absxi = (r__1 = x[ix], dabs(r__1)); - if (*scale < absxi) { -/* Computing 2nd power */ - r__1 = *scale / absxi; - *sumsq = *sumsq * (r__1 * r__1) + 1; - *scale = absxi; - } else { -/* Computing 2nd power */ - r__1 = absxi / *scale; - *sumsq += r__1 * r__1; - } - } -/* L10: */ - } - } - return 0; - -/* End of SLASSQ */ - -} /* slassq_ */ diff --git a/3rdparty/lapack/slasv2.c b/3rdparty/lapack/slasv2.c deleted file mode 100644 index 9cce1d9..0000000 --- a/3rdparty/lapack/slasv2.c +++ /dev/null @@ -1,273 +0,0 @@ -/* slasv2.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 real c_b3 = 2.f; -static real c_b4 = 1.f; - -/* Subroutine */ int slasv2_(real *f, real *g, real *h__, real *ssmin, real * - ssmax, real *snr, real *csr, real *snl, real *csl) -{ - /* System generated locals */ - real r__1; - - /* Builtin functions */ - double sqrt(doublereal), r_sign(real *, real *); - - /* Local variables */ - real a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, crt, - slt, srt; - integer pmax; - real temp; - logical swap; - real tsign; - logical gasmal; - extern doublereal slamch_(char *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASV2 computes the singular value decomposition of a 2-by-2 */ -/* triangular matrix */ -/* [ F G ] */ -/* [ 0 H ]. */ -/* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */ -/* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */ -/* right singular vectors for abs(SSMAX), giving the decomposition */ - -/* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */ -/* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */ - -/* Arguments */ -/* ========= */ - -/* F (input) REAL */ -/* The (1,1) element of the 2-by-2 matrix. */ - -/* G (input) REAL */ -/* The (1,2) element of the 2-by-2 matrix. */ - -/* H (input) REAL */ -/* The (2,2) element of the 2-by-2 matrix. */ - -/* SSMIN (output) REAL */ -/* abs(SSMIN) is the smaller singular value. */ - -/* SSMAX (output) REAL */ -/* abs(SSMAX) is the larger singular value. */ - -/* SNL (output) REAL */ -/* CSL (output) REAL */ -/* The vector (CSL, SNL) is a unit left singular vector for the */ -/* singular value abs(SSMAX). */ - -/* SNR (output) REAL */ -/* CSR (output) REAL */ -/* The vector (CSR, SNR) is a unit right singular vector for the */ -/* singular value abs(SSMAX). */ - -/* Further Details */ -/* =============== */ - -/* Any input parameter may be aliased with any output parameter. */ - -/* Barring over/underflow and assuming a guard digit in subtraction, all */ -/* output quantities are correct to within a few units in the last */ -/* place (ulps). */ - -/* 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 .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - ft = *f; - fa = dabs(ft); - ht = *h__; - ha = dabs(*h__); - -/* PMAX points to the maximum absolute element of matrix */ -/* PMAX = 1 if F largest in absolute values */ -/* PMAX = 2 if G largest in absolute values */ -/* PMAX = 3 if H largest in absolute values */ - - pmax = 1; - swap = ha > fa; - if (swap) { - pmax = 3; - temp = ft; - ft = ht; - ht = temp; - temp = fa; - fa = ha; - ha = temp; - -/* Now FA .ge. HA */ - - } - gt = *g; - ga = dabs(gt); - if (ga == 0.f) { - -/* Diagonal matrix */ - - *ssmin = ha; - *ssmax = fa; - clt = 1.f; - crt = 1.f; - slt = 0.f; - srt = 0.f; - } else { - gasmal = TRUE_; - if (ga > fa) { - pmax = 2; - if (fa / ga < slamch_("EPS")) { - -/* Case of very large GA */ - - gasmal = FALSE_; - *ssmax = ga; - if (ha > 1.f) { - *ssmin = fa / (ga / ha); - } else { - *ssmin = fa / ga * ha; - } - clt = 1.f; - slt = ht / gt; - srt = 1.f; - crt = ft / gt; - } - } - if (gasmal) { - -/* Normal case */ - - d__ = fa - ha; - if (d__ == fa) { - -/* Copes with infinite F or H */ - - l = 1.f; - } else { - l = d__ / fa; - } - -/* Note that 0 .le. L .le. 1 */ - - m = gt / ft; - -/* Note that abs(M) .le. 1/macheps */ - - t = 2.f - l; - -/* Note that T .ge. 1 */ - - mm = m * m; - tt = t * t; - s = sqrt(tt + mm); - -/* Note that 1 .le. S .le. 1 + 1/macheps */ - - if (l == 0.f) { - r__ = dabs(m); - } else { - r__ = sqrt(l * l + mm); - } - -/* Note that 0 .le. R .le. 1 + 1/macheps */ - - a = (s + r__) * .5f; - -/* Note that 1 .le. A .le. 1 + abs(M) */ - - *ssmin = ha / a; - *ssmax = fa * a; - if (mm == 0.f) { - -/* Note that M is very tiny */ - - if (l == 0.f) { - t = r_sign(&c_b3, &ft) * r_sign(&c_b4, >); - } else { - t = gt / r_sign(&d__, &ft) + m / t; - } - } else { - t = (m / (s + t) + m / (r__ + l)) * (a + 1.f); - } - l = sqrt(t * t + 4.f); - crt = 2.f / l; - srt = t / l; - clt = (crt + srt * m) / a; - slt = ht / ft * srt / a; - } - } - if (swap) { - *csl = srt; - *snl = crt; - *csr = slt; - *snr = clt; - } else { - *csl = clt; - *snl = slt; - *csr = crt; - *snr = srt; - } - -/* Correct signs of SSMAX and SSMIN */ - - if (pmax == 1) { - tsign = r_sign(&c_b4, csr) * r_sign(&c_b4, csl) * r_sign(&c_b4, f); - } - if (pmax == 2) { - tsign = r_sign(&c_b4, snr) * r_sign(&c_b4, csl) * r_sign(&c_b4, g); - } - if (pmax == 3) { - tsign = r_sign(&c_b4, snr) * r_sign(&c_b4, snl) * r_sign(&c_b4, h__); - } - *ssmax = r_sign(ssmax, &tsign); - r__1 = tsign * r_sign(&c_b4, f) * r_sign(&c_b4, h__); - *ssmin = r_sign(ssmin, &r__1); - return 0; - -/* End of SLASV2 */ - -} /* slasv2_ */ diff --git a/3rdparty/lapack/slaswp.c b/3rdparty/lapack/slaswp.c deleted file mode 100644 index dbe5a97..0000000 --- a/3rdparty/lapack/slaswp.c +++ /dev/null @@ -1,158 +0,0 @@ -/* slaswp.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 slaswp_(integer *n, real *a, integer *lda, integer *k1, - integer *k2, integer *ipiv, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; - real temp; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLASWP performs a series of row interchanges on the matrix A. */ -/* One row interchange is initiated for each of rows K1 through K2 of A. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the matrix of column dimension N to which the row */ -/* interchanges will be applied. */ -/* On exit, the permuted matrix. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ - -/* K1 (input) INTEGER */ -/* The first element of IPIV for which a row interchange will */ -/* be done. */ - -/* K2 (input) INTEGER */ -/* The last element of IPIV for which a row interchange will */ -/* be done. */ - -/* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) */ -/* The vector of pivot indices. Only the elements in positions */ -/* K1 through K2 of IPIV are accessed. */ -/* IPIV(K) = L implies rows K and L are to be interchanged. */ - -/* INCX (input) INTEGER */ -/* The increment between successive values of IPIV. If IPIV */ -/* is negative, the pivots are applied in reverse order. */ - -/* Further Details */ -/* =============== */ - -/* Modified by */ -/* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Interchange row I with row IPIV(I) for each of rows K1 through K2. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - - /* Function Body */ - if (*incx > 0) { - ix0 = *k1; - i1 = *k1; - i2 = *k2; - inc = 1; - } else if (*incx < 0) { - ix0 = (1 - *k2) * *incx + 1; - i1 = *k2; - i2 = *k1; - inc = -1; - } else { - return 0; - } - - n32 = *n / 32 << 5; - if (n32 != 0) { - i__1 = n32; - for (j = 1; j <= i__1; j += 32) { - ix = ix0; - i__2 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) - { - ip = ipiv[ix]; - if (ip != i__) { - i__4 = j + 31; - for (k = j; k <= i__4; ++k) { - temp = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = a[ip + k * a_dim1]; - a[ip + k * a_dim1] = temp; -/* L10: */ - } - } - ix += *incx; -/* L20: */ - } -/* L30: */ - } - } - if (n32 != *n) { - ++n32; - ix = ix0; - i__1 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { - ip = ipiv[ix]; - if (ip != i__) { - i__2 = *n; - for (k = n32; k <= i__2; ++k) { - temp = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = a[ip + k * a_dim1]; - a[ip + k * a_dim1] = temp; -/* L40: */ - } - } - ix += *incx; -/* L50: */ - } - } - - return 0; - -/* End of SLASWP */ - -} /* slaswp_ */ diff --git a/3rdparty/lapack/slatrd.c b/3rdparty/lapack/slatrd.c deleted file mode 100644 index 38f6a61..0000000 --- a/3rdparty/lapack/slatrd.c +++ /dev/null @@ -1,351 +0,0 @@ -/* slatrd.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 real c_b5 = -1.f; -static real c_b6 = 1.f; -static integer c__1 = 1; -static real c_b16 = 0.f; - -/* Subroutine */ int slatrd_(char *uplo, integer *n, integer *nb, real *a, - integer *lda, real *e, real *tau, real *w, integer *ldw) -{ - /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, iw; - extern doublereal sdot_(integer *, real *, integer *, real *, integer *); - real alpha; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), - sgemv_(char *, integer *, integer *, real *, real *, integer *, - real *, integer *, real *, real *, integer *), saxpy_( - integer *, real *, real *, integer *, real *, integer *), ssymv_( - char *, integer *, real *, real *, integer *, real *, integer *, - real *, real *, integer *), slarfg_(integer *, real *, - real *, integer *, real *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLATRD reduces NB rows and columns of a real symmetric matrix A to */ -/* symmetric tridiagonal form by an orthogonal similarity */ -/* transformation Q' * A * Q, and returns the matrices V and W which are */ -/* needed to apply the transformation to the unreduced part of A. */ - -/* If UPLO = 'U', SLATRD reduces the last NB rows and columns of a */ -/* matrix, of which the upper triangle is supplied; */ -/* if UPLO = 'L', SLATRD reduces the first NB rows and columns of a */ -/* matrix, of which the lower triangle is supplied. */ - -/* This is an auxiliary routine called by SSYTRD. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* NB (input) INTEGER */ -/* The number of rows and columns to be reduced. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit: */ -/* if UPLO = 'U', the last NB columns have been reduced to */ -/* tridiagonal form, with the diagonal elements overwriting */ -/* the diagonal elements of A; the elements above the diagonal */ -/* with the array TAU, represent the orthogonal matrix Q as a */ -/* product of elementary reflectors; */ -/* if UPLO = 'L', the first NB columns have been reduced to */ -/* tridiagonal form, with the diagonal elements overwriting */ -/* the diagonal elements of A; 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 >= (1,N). */ - -/* E (output) REAL array, dimension (N-1) */ -/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */ -/* elements of the last NB columns of the reduced matrix; */ -/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */ -/* the first NB columns of the reduced matrix. */ - -/* TAU (output) REAL array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors, stored in */ -/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */ -/* See Further Details. */ - -/* W (output) REAL array, dimension (LDW,NB) */ -/* The n-by-nb matrix W required to update the unreduced part */ -/* of A. */ - -/* LDW (input) INTEGER */ -/* The leading dimension of the array W. LDW >= max(1,N). */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n) H(n-1) . . . H(n-nb+1). */ - -/* 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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */ -/* and tau in TAU(i-1). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(nb). */ - -/* 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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ -/* and tau in TAU(i). */ - -/* The elements of the vectors v together form the n-by-nb matrix V */ -/* which is needed, with W, to apply the transformation to the unreduced */ -/* part of the matrix, using a symmetric rank-2k update of the form: */ -/* A := A - V*W' - W*V'. */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5 and nb = 2: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( a a a v4 v5 ) ( d ) */ -/* ( a a v4 v5 ) ( 1 d ) */ -/* ( a 1 v5 ) ( v1 1 a ) */ -/* ( d 1 ) ( v1 v2 a a ) */ -/* ( d ) ( v1 v2 a a a ) */ - -/* where d denotes a diagonal element of the reduced matrix, a denotes */ -/* an element of the original matrix that is unchanged, and vi denotes */ -/* an element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --e; - --tau; - w_dim1 = *ldw; - w_offset = 1 + w_dim1; - w -= w_offset; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - - if (lsame_(uplo, "U")) { - -/* Reduce last NB columns of upper triangle */ - - i__1 = *n - *nb + 1; - for (i__ = *n; i__ >= i__1; --i__) { - iw = i__ - *n + *nb; - if (i__ < *n) { - -/* Update A(1:i,i) */ - - i__2 = *n - i__; - sgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & - c_b6, &a[i__ * a_dim1 + 1], &c__1); - i__2 = *n - i__; - sgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & - c_b6, &a[i__ * a_dim1 + 1], &c__1); - } - if (i__ > 1) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(1:i-2,i) */ - - i__2 = i__ - 1; - slarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + - 1], &c__1, &tau[i__ - 1]); - e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; - a[i__ - 1 + i__ * a_dim1] = 1.f; - -/* Compute W(1:i-1,i) */ - - i__2 = i__ - 1; - ssymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * - a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], & - c__1); - if (i__ < *n) { - i__2 = i__ - 1; - i__3 = *n - i__; - sgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, & - c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - sgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, & - c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * - w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); - } - i__2 = i__ - 1; - sscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); - i__2 = i__ - 1; - alpha = tau[i__ - 1] * -.5f * sdot_(&i__2, &w[iw * w_dim1 + 1] -, &c__1, &a[i__ * a_dim1 + 1], &c__1); - i__2 = i__ - 1; - saxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * - w_dim1 + 1], &c__1); - } - -/* L10: */ - } - } else { - -/* Reduce first NB columns of lower triangle */ - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Update A(i:n,i) */ - - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, - &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], & - c__1); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, - &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], & - c__1); - if (i__ < *n) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(i+2:n,i) */ - - i__2 = *n - i__; -/* Computing MIN */ - i__3 = i__ + 2; - slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ - i__ * a_dim1], &c__1, &tau[i__]); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.f; - -/* Compute W(i+1:n,i) */ - - i__2 = *n - i__; - ssymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1] -, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - sgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], - ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ * w_dim1 + 1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + - a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - sgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ * w_dim1 + 1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + - w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - sscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - alpha = tau[i__] * -.5f * sdot_(&i__2, &w[i__ + 1 + i__ * - w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - i__2 = *n - i__; - saxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - } - -/* L20: */ - } - } - - return 0; - -/* End of SLATRD */ - -} /* slatrd_ */ diff --git a/3rdparty/lapack/slauu2.c b/3rdparty/lapack/slauu2.c deleted file mode 100644 index 354c973..0000000 --- a/3rdparty/lapack/slauu2.c +++ /dev/null @@ -1,180 +0,0 @@ -/* slauu2.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 real c_b7 = 1.f; -static integer c__1 = 1; - -/* Subroutine */ int slauu2_(char *uplo, integer *n, real *a, integer *lda, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - real aii; - extern doublereal sdot_(integer *, real *, integer *, real *, integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), - sgemv_(char *, integer *, integer *, real *, real *, integer *, - real *, integer *, real *, real *, integer *); - logical upper; - 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 */ -/* ======= */ - -/* SLAUU2 computes the product U * U' or L' * L, where the triangular */ -/* factor U or L is stored in the upper or lower triangular part of */ -/* the array A. */ - -/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* overwriting the factor U in A. */ -/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* overwriting the factor L in A. */ - -/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the triangular factor stored in the array A */ -/* is upper or lower triangular: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the triangular factor U or L. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L. */ -/* On exit, if UPLO = 'U', the upper triangle of A is */ -/* overwritten with the upper triangle of the product U * U'; */ -/* if UPLO = 'L', the lower triangle of A is overwritten with */ -/* the lower triangle of the product L' * L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SLAUU2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the product U * U'. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - aii = a[i__ + i__ * a_dim1]; - if (i__ < *n) { - i__2 = *n - i__ + 1; - a[i__ + i__ * a_dim1] = sdot_(&i__2, &a[i__ + i__ * a_dim1], - lda, &a[i__ + i__ * a_dim1], lda); - i__2 = i__ - 1; - i__3 = *n - i__; - sgemv_("No transpose", &i__2, &i__3, &c_b7, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & - aii, &a[i__ * a_dim1 + 1], &c__1); - } else { - sscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1); - } -/* L10: */ - } - - } else { - -/* Compute the product L' * L. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - aii = a[i__ + i__ * a_dim1]; - if (i__ < *n) { - i__2 = *n - i__ + 1; - a[i__ + i__ * a_dim1] = sdot_(&i__2, &a[i__ + i__ * a_dim1], & - c__1, &a[i__ + i__ * a_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - sgemv_("Transpose", &i__2, &i__3, &c_b7, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &aii, &a[i__ - + a_dim1], lda); - } else { - sscal_(&i__, &aii, &a[i__ + a_dim1], lda); - } -/* L20: */ - } - } - - return 0; - -/* End of SLAUU2 */ - -} /* slauu2_ */ diff --git a/3rdparty/lapack/slauum.c b/3rdparty/lapack/slauum.c deleted file mode 100644 index 4f99e6b..0000000 --- a/3rdparty/lapack/slauum.c +++ /dev/null @@ -1,215 +0,0 @@ -/* slauum.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 real c_b15 = 1.f; - -/* Subroutine */ int slauum_(char *uplo, integer *n, real *a, integer *lda, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, ib, nb; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - logical upper; - extern /* Subroutine */ int strmm_(char *, char *, char *, char *, - integer *, integer *, real *, real *, integer *, real *, integer * -), ssyrk_(char *, char *, integer - *, integer *, real *, real *, integer *, real *, real *, integer * -), slauu2_(char *, integer *, real *, integer *, - integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAUUM computes the product U * U' or L' * L, where the triangular */ -/* factor U or L is stored in the upper or lower triangular part of */ -/* the array A. */ - -/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* overwriting the factor U in A. */ -/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* overwriting the factor L in A. */ - -/* This is the blocked form of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the triangular factor stored in the array A */ -/* is upper or lower triangular: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the triangular factor U or L. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L. */ -/* On exit, if UPLO = 'U', the upper triangle of A is */ -/* overwritten with the upper triangle of the product U * U'; */ -/* if UPLO = 'L', the lower triangle of A is overwritten with */ -/* the lower triangle of the product L' * L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SLAUUM", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "SLAUUM", uplo, n, &c_n1, &c_n1, &c_n1); - - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - slauu2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute the product U * U'. */ - - i__1 = *n; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = min(i__3,i__4); - i__3 = i__ - 1; - strmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, - &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 - + 1], lda) - ; - slauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - sgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & - c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + - (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * - a_dim1 + 1], lda); - i__3 = *n - i__ - ib + 1; - ssyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ - i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + - i__ * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the product L' * L. */ - - i__2 = *n; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = min(i__3,i__4); - i__3 = i__ - 1; - strmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & - c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], - lda); - slauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - sgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & - c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + - ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); - i__3 = *n - i__ - ib + 1; - ssyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + - ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * - a_dim1], lda); - } -/* L20: */ - } - } - } - - return 0; - -/* End of SLAUUM */ - -} /* slauum_ */ diff --git a/3rdparty/lapack/snrm2.c b/3rdparty/lapack/snrm2.c deleted file mode 100644 index 3184861..0000000 --- a/3rdparty/lapack/snrm2.c +++ /dev/null @@ -1,97 +0,0 @@ -/* snrm2.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 snrm2_(integer *n, real *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - real ret_val, r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer ix; - real ssq, norm, scale, absxi; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SNRM2 returns the euclidean norm of a vector via the function */ -/* name, so that */ - -/* SNRM2 := sqrt( x'*x ). */ - -/* Further Details */ -/* =============== */ - -/* -- This version written on 25-October-1982. */ -/* Modified on 14-October-1993 to inline the call to SLASSQ. */ -/* Sven Hammarling, Nag Ltd. */ - - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n < 1 || *incx < 1) { - norm = 0.f; - } else if (*n == 1) { - norm = dabs(x[1]); - } else { - scale = 0.f; - ssq = 1.f; -/* The following loop is equivalent to this call to the LAPACK */ -/* auxiliary routine: */ -/* CALL SLASSQ( N, X, INCX, SCALE, SSQ ) */ - - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.f) { - absxi = (r__1 = x[ix], dabs(r__1)); - if (scale < absxi) { -/* Computing 2nd power */ - r__1 = scale / absxi; - ssq = ssq * (r__1 * r__1) + 1.f; - scale = absxi; - } else { -/* Computing 2nd power */ - r__1 = absxi / scale; - ssq += r__1 * r__1; - } - } -/* L10: */ - } - norm = scale * sqrt(ssq); - } - - ret_val = norm; - return ret_val; - -/* End of SNRM2. */ - -} /* snrm2_ */ diff --git a/3rdparty/lapack/sorg2r.c b/3rdparty/lapack/sorg2r.c deleted file mode 100644 index 041c03c..0000000 --- a/3rdparty/lapack/sorg2r.c +++ /dev/null @@ -1,175 +0,0 @@ -/* sorg2r.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 sorg2r_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - real r__1; - - /* Local variables */ - integer i__, j, l; - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), - slarf_(char *, integer *, integer *, real *, integer *, real *, - real *, integer *, real *), 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 */ -/* ======= */ - -/* SORG2R generates an m by n real matrix Q with orthonormal columns, */ -/* which is defined as the first n columns of a product of k elementary */ -/* reflectors of order m */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by SGEQRF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. M >= N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. N >= K >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the i-th column must contain the vector which */ -/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ -/* returned by SGEQRF in the first k columns of its array */ -/* argument A. */ -/* On exit, the m-by-n matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGEQRF. */ - -/* WORK (workspace) REAL array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. 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 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORG2R", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - -/* Initialise columns k+1:n to columns of the unit matrix */ - - i__1 = *n; - for (j = *k + 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.f; -/* L10: */ - } - a[j + j * a_dim1] = 1.f; -/* L20: */ - } - - for (i__ = *k; i__ >= 1; --i__) { - -/* Apply H(i) to A(i:m,i:n) from the left */ - - if (i__ < *n) { - a[i__ + i__ * a_dim1] = 1.f; - i__1 = *m - i__ + 1; - i__2 = *n - i__; - slarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ - i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); - } - if (i__ < *m) { - i__1 = *m - i__; - r__1 = -tau[i__]; - sscal_(&i__1, &r__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - } - a[i__ + i__ * a_dim1] = 1.f - tau[i__]; - -/* Set A(1:i-1,i) to zero */ - - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a[l + i__ * a_dim1] = 0.f; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of SORG2R */ - -} /* sorg2r_ */ diff --git a/3rdparty/lapack/sorgbr.c b/3rdparty/lapack/sorgbr.c deleted file mode 100644 index 1b6b59b..0000000 --- a/3rdparty/lapack/sorgbr.c +++ /dev/null @@ -1,299 +0,0 @@ -/* sorgbr.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 sorgbr_(char *vect, integer *m, integer *n, integer *k, - real *a, integer *lda, real *tau, real *work, integer *lwork, integer - *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, nb, mn; - extern logical lsame_(char *, char *); - integer iinfo; - logical wantq; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int sorglq_(integer *, integer *, integer *, real - *, integer *, real *, real *, integer *, integer *), sorgqr_( - integer *, integer *, integer *, real *, integer *, real *, real * -, 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 */ -/* ======= */ - -/* SORGBR generates one of the real orthogonal matrices Q or P**T */ -/* determined by SGEBRD when reducing a real matrix A to bidiagonal */ -/* form: A = Q * B * P**T. Q and P**T are defined as products of */ -/* elementary reflectors H(i) or G(i) respectively. */ - -/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */ -/* is of order M: */ -/* if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n */ -/* columns of Q, where m >= n >= k; */ -/* if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an */ -/* M-by-M matrix. */ - -/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */ -/* is of order N: */ -/* if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m */ -/* rows of P**T, where n >= m >= k; */ -/* if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as */ -/* an N-by-N matrix. */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* Specifies whether the matrix Q or the matrix P**T is */ -/* required, as defined in the transformation applied by SGEBRD: */ -/* = 'Q': generate Q; */ -/* = 'P': generate P**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q or P**T to be returned. */ -/* M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q or P**T to be returned. */ -/* N >= 0. */ -/* If VECT = 'Q', M >= N >= min(M,K); */ -/* if VECT = 'P', N >= M >= min(N,K). */ - -/* K (input) INTEGER */ -/* If VECT = 'Q', the number of columns in the original M-by-K */ -/* matrix reduced by SGEBRD. */ -/* If VECT = 'P', the number of rows in the original K-by-N */ -/* matrix reduced by SGEBRD. */ -/* K >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the vectors which define the elementary reflectors, */ -/* as returned by SGEBRD. */ -/* On exit, the M-by-N matrix Q or P**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) REAL array, dimension */ -/* (min(M,K)) if VECT = 'Q' */ -/* (min(N,K)) if VECT = 'P' */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i) or G(i), which determines Q or P**T, as */ -/* returned by SGEBRD in its array argument TAUQ or TAUP. */ - -/* WORK (workspace/output) REAL 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,min(M,N)). */ -/* For optimum performance LWORK >= min(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 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. 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; - --tau; - --work; - - /* Function Body */ - *info = 0; - wantq = lsame_(vect, "Q"); - mn = min(*m,*n); - lquery = *lwork == -1; - if (! wantq && ! lsame_(vect, "P")) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && ( - *m > *n || *m < min(*n,*k))) { - *info = -3; - } else if (*k < 0) { - *info = -4; - } else if (*lda < max(1,*m)) { - *info = -6; - } else if (*lwork < max(1,mn) && ! lquery) { - *info = -9; - } - - if (*info == 0) { - if (wantq) { - nb = ilaenv_(&c__1, "SORGQR", " ", m, n, k, &c_n1); - } else { - nb = ilaenv_(&c__1, "SORGLQ", " ", m, n, k, &c_n1); - } - lwkopt = max(1,mn) * nb; - work[1] = (real) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORGBR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - work[1] = 1.f; - return 0; - } - - if (wantq) { - -/* Form Q, determined by a call to SGEBRD to reduce an m-by-k */ -/* matrix */ - - if (*m >= *k) { - -/* If m >= k, assume m >= n >= k */ - - sorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); - - } else { - -/* If m < k, assume m = n */ - -/* Shift the vectors which define the elementary reflectors one */ -/* column to the right, and set the first row and column of Q */ -/* to those of the unit matrix */ - - for (j = *m; j >= 2; --j) { - a[j * a_dim1 + 1] = 0.f; - i__1 = *m; - for (i__ = j + 1; i__ <= i__1; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; -/* L10: */ - } -/* L20: */ - } - a[a_dim1 + 1] = 1.f; - i__1 = *m; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.f; -/* L30: */ - } - if (*m > 1) { - -/* Form Q(2:m,2:m) */ - - i__1 = *m - 1; - i__2 = *m - 1; - i__3 = *m - 1; - sorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ - 1], &work[1], lwork, &iinfo); - } - } - } else { - -/* Form P', determined by a call to SGEBRD to reduce a k-by-n */ -/* matrix */ - - if (*k < *n) { - -/* If k < n, assume k <= m <= n */ - - sorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); - - } else { - -/* If k >= n, assume m = n */ - -/* Shift the vectors which define the elementary reflectors one */ -/* row downward, and set the first row and column of P' to */ -/* those of the unit matrix */ - - a[a_dim1 + 1] = 1.f; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.f; -/* L40: */ - } - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - for (i__ = j - 1; i__ >= 2; --i__) { - a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1]; -/* L50: */ - } - a[j * a_dim1 + 1] = 0.f; -/* L60: */ - } - if (*n > 1) { - -/* Form P'(2:n,2:n) */ - - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - sorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ - 1], &work[1], lwork, &iinfo); - } - } - } - work[1] = (real) lwkopt; - return 0; - -/* End of SORGBR */ - -} /* sorgbr_ */ diff --git a/3rdparty/lapack/sorgl2.c b/3rdparty/lapack/sorgl2.c deleted file mode 100644 index f11a840..0000000 --- a/3rdparty/lapack/sorgl2.c +++ /dev/null @@ -1,175 +0,0 @@ -/* sorgl2.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 sorgl2_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - real r__1; - - /* Local variables */ - integer i__, j, l; - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), - slarf_(char *, integer *, integer *, real *, integer *, real *, - real *, integer *, real *), 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 */ -/* ======= */ - -/* SORGL2 generates an m by n real matrix Q with orthonormal rows, */ -/* which is defined as the first m rows of a product of k elementary */ -/* reflectors of order n */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by SGELQF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. N >= M. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. M >= K >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the i-th row must contain the vector which defines */ -/* the elementary reflector H(i), for i = 1,2,...,k, as returned */ -/* by SGELQF in the first k rows of its array argument A. */ -/* On exit, the m-by-n matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGELQF. */ - -/* WORK (workspace) REAL array, dimension (M) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. 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 < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORGL2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - return 0; - } - - if (*k < *m) { - -/* Initialise rows k+1:m to rows of the unit matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = *k + 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.f; -/* L10: */ - } - if (j > *k && j <= *m) { - a[j + j * a_dim1] = 1.f; - } -/* L20: */ - } - } - - for (i__ = *k; i__ >= 1; --i__) { - -/* Apply H(i) to A(i:m,i:n) from the right */ - - if (i__ < *n) { - if (i__ < *m) { - a[i__ + i__ * a_dim1] = 1.f; - i__1 = *m - i__; - i__2 = *n - i__ + 1; - slarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & - tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); - } - i__1 = *n - i__; - r__1 = -tau[i__]; - sscal_(&i__1, &r__1, &a[i__ + (i__ + 1) * a_dim1], lda); - } - a[i__ + i__ * a_dim1] = 1.f - tau[i__]; - -/* Set A(i,1:i-1) to zero */ - - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a[i__ + l * a_dim1] = 0.f; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of SORGL2 */ - -} /* sorgl2_ */ diff --git a/3rdparty/lapack/sorglq.c b/3rdparty/lapack/sorglq.c deleted file mode 100644 index 846562f..0000000 --- a/3rdparty/lapack/sorglq.c +++ /dev/null @@ -1,279 +0,0 @@ -/* sorglq.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 sorglq_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int sorgl2_(integer *, integer *, integer *, real - *, integer *, real *, real *, integer *), slarfb_(char *, char *, - char *, char *, integer *, integer *, integer *, real *, integer * -, real *, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *, - real *, integer *, real *, real *, 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 */ -/* ======= */ - -/* SORGLQ generates an M-by-N real matrix Q with orthonormal rows, */ -/* which is defined as the first M rows of a product of K elementary */ -/* reflectors of order N */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by SGELQF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. N >= M. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. M >= K >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the i-th row must contain the vector which defines */ -/* the elementary reflector H(i), for i = 1,2,...,k, as returned */ -/* by SGELQF in the first k rows of its array argument A. */ -/* On exit, the M-by-N matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGELQF. */ - -/* WORK (workspace/output) REAL 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 has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. 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, "SORGLQ", " ", m, n, k, &c_n1); - lwkopt = max(1,*m) * nb; - work[1] = (real) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*lwork < max(1,*m) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORGLQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - work[1] = 1.f; - 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, "SORGLQ", " ", m, n, k, &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, "SORGLQ", " ", m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the last block. */ -/* The first kk rows are handled by the block method. */ - - ki = (*k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); - -/* Set A(kk+1:m,1:kk) to zero. */ - - i__1 = kk; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = kk + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.f; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the last or only block. */ - - if (kk < *m) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - sorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); - } - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *m) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__2 = *n - i__ + 1; - slarft_("Forward", "Rowwise", &i__2, &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__2 = *m - i__ - ib + 1; - i__3 = *n - i__ + 1; - slarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, & - i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & - ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + - 1], &ldwork); - } - -/* Apply H' to columns i:n of current block */ - - i__2 = *n - i__ + 1; - sorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); - -/* Set columns 1:i-1 of current block to zero */ - - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = i__ + ib - 1; - for (l = i__; l <= i__3; ++l) { - a[l + j * a_dim1] = 0.f; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (real) iws; - return 0; - -/* End of SORGLQ */ - -} /* sorglq_ */ diff --git a/3rdparty/lapack/sorgqr.c b/3rdparty/lapack/sorgqr.c deleted file mode 100644 index bbdb54e..0000000 --- a/3rdparty/lapack/sorgqr.c +++ /dev/null @@ -1,280 +0,0 @@ -/* sorgqr.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 sorgqr_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - extern /* Subroutine */ int sorg2r_(integer *, integer *, integer *, real - *, integer *, real *, real *, integer *), slarfb_(char *, char *, - char *, char *, integer *, integer *, integer *, real *, integer * -, real *, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *, - real *, integer *, real *, real *, 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 */ -/* ======= */ - -/* SORGQR generates an M-by-N real matrix Q with orthonormal columns, */ -/* which is defined as the first N columns of a product of K elementary */ -/* reflectors of order M */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by SGEQRF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. M >= N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. N >= K >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the i-th column must contain the vector which */ -/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ -/* returned by SGEQRF in the first k columns of its array */ -/* argument A. */ -/* On exit, the M-by-N matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGEQRF. */ - -/* WORK (workspace/output) REAL 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 has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. 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, "SORGQR", " ", m, n, k, &c_n1); - lwkopt = max(1,*n) * nb; - work[1] = (real) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*lwork < max(1,*n) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORGQR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - work[1] = 1.f; - 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, "SORGQR", " ", m, n, k, &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, "SORGQR", " ", m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the last block. */ -/* The first kk columns are handled by the block method. */ - - ki = (*k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); - -/* Set A(1:kk,kk+1:n) to zero. */ - - i__1 = *n; - for (j = kk + 1; j <= i__1; ++j) { - i__2 = kk; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.f; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the last or only block. */ - - if (kk < *n) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - sorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); - } - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *n) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__2 = *m - i__ + 1; - slarft_("Forward", "Columnwise", &i__2, &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__2 = *m - i__ + 1; - i__3 = *n - i__ - ib + 1; - slarfb_("Left", "No transpose", "Forward", "Columnwise", & - i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ - 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & - work[ib + 1], &ldwork); - } - -/* Apply H to rows i:m of current block */ - - i__2 = *m - i__ + 1; - sorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); - -/* Set rows 1:i-1 of current block to zero */ - - i__2 = i__ + ib - 1; - for (j = i__; j <= i__2; ++j) { - i__3 = i__ - 1; - for (l = 1; l <= i__3; ++l) { - a[l + j * a_dim1] = 0.f; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (real) iws; - return 0; - -/* End of SORGQR */ - -} /* sorgqr_ */ diff --git a/3rdparty/lapack/sorm2l.c b/3rdparty/lapack/sorm2l.c deleted file mode 100644 index 0665799..0000000 --- a/3rdparty/lapack/sorm2l.c +++ /dev/null @@ -1,230 +0,0 @@ -/* sorm2l.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 sorm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, mi, ni, nq; - real aii; - logical left; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, - integer *, real *, real *, integer *, real *), xerbla_( - char *, 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 */ -/* ======= */ - -/* SORM2L overwrites the general real m by n matrix C with */ - -/* Q * C if SIDE = 'L' and TRANS = 'N', or */ - -/* Q'* C if SIDE = 'L' and TRANS = 'T', or */ - -/* C * Q if SIDE = 'R' and TRANS = 'N', or */ - -/* C * Q' if SIDE = 'R' and TRANS = 'T', */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q' from the Left */ -/* = 'R': apply Q or Q' from the Right */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply Q (No transpose) */ -/* = 'T': apply Q' (Transpose) */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) REAL array, dimension (LDA,K) */ -/* The i-th column must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* SGEQLF in the last k columns of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If SIDE = 'L', LDA >= max(1,M); */ -/* if SIDE = 'R', LDA >= max(1,N). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGEQLF. */ - -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the m by n matrix C. */ -/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace) REAL array, dimension */ -/* (N) if SIDE = 'L', */ -/* (M) if SIDE = 'R' */ - -/* 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 arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORM2L", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(1:m-k+i,1:n) */ - - mi = *m - *k + i__; - } else { - -/* H(i) is applied to C(1:m,1:n-k+i) */ - - ni = *n - *k + i__; - } - -/* Apply H(i) */ - - aii = a[nq - *k + i__ + i__ * a_dim1]; - a[nq - *k + i__ + i__ * a_dim1] = 1.f; - slarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[ - c_offset], ldc, &work[1]); - a[nq - *k + i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of SORM2L */ - -} /* sorm2l_ */ diff --git a/3rdparty/lapack/sorm2r.c b/3rdparty/lapack/sorm2r.c deleted file mode 100644 index 8b6d727..0000000 --- a/3rdparty/lapack/sorm2r.c +++ /dev/null @@ -1,234 +0,0 @@ -/* sorm2r.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 sorm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, ic, jc, mi, ni, nq; - real aii; - logical left; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, - integer *, real *, real *, integer *, real *), xerbla_( - char *, 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 */ -/* ======= */ - -/* SORM2R overwrites the general real m by n matrix C with */ - -/* Q * C if SIDE = 'L' and TRANS = 'N', or */ - -/* Q'* C if SIDE = 'L' and TRANS = 'T', or */ - -/* C * Q if SIDE = 'R' and TRANS = 'N', or */ - -/* C * Q' if SIDE = 'R' and TRANS = 'T', */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q' from the Left */ -/* = 'R': apply Q or Q' from the Right */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply Q (No transpose) */ -/* = 'T': apply Q' (Transpose) */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) REAL array, dimension (LDA,K) */ -/* The i-th column must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* SGEQRF in the first k columns of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If SIDE = 'L', LDA >= max(1,M); */ -/* if SIDE = 'R', LDA >= max(1,N). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGEQRF. */ - -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the m by n matrix C. */ -/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace) REAL array, dimension */ -/* (N) if SIDE = 'L', */ -/* (M) if SIDE = 'R' */ - -/* 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 arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORM2R", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H(i) is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H(i) */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.f; - slarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1]); - a[i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of SORM2R */ - -} /* sorm2r_ */ diff --git a/3rdparty/lapack/sormbr.c b/3rdparty/lapack/sormbr.c deleted file mode 100644 index 24023b8..0000000 --- a/3rdparty/lapack/sormbr.c +++ /dev/null @@ -1,358 +0,0 @@ -/* sormbr.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; - -/* Subroutine */ int sormbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, real *a, integer *lda, real *tau, real *c__, - integer *ldc, real *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i1, i2, nb, mi, ni, nq, nw; - logical left; - extern logical lsame_(char *, char *); - integer iinfo; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - logical notran, applyq; - char transt[1]; - extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *, integer *); - integer lwkopt; - logical lquery; - extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C */ -/* with */ -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C */ -/* with */ -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': P * C C * P */ -/* TRANS = 'T': P**T * C C * P**T */ - -/* Here Q and P**T are the orthogonal matrices determined by SGEBRD when */ -/* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and */ -/* P**T are defined as products of elementary reflectors H(i) and G(i) */ -/* respectively. */ - -/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */ -/* order of the orthogonal matrix Q or P**T that is applied. */ - -/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */ -/* if nq >= k, Q = H(1) H(2) . . . H(k); */ -/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */ - -/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */ -/* if k < nq, P = G(1) G(2) . . . G(k); */ -/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* = 'Q': apply Q or Q**T; */ -/* = 'P': apply P or P**T. */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q, Q**T, P or P**T from the Left; */ -/* = 'R': apply Q, Q**T, P or P**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q or P; */ -/* = 'T': Transpose, apply Q**T or P**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* If VECT = 'Q', the number of columns in the original */ -/* matrix reduced by SGEBRD. */ -/* If VECT = 'P', the number of rows in the original */ -/* matrix reduced by SGEBRD. */ -/* K >= 0. */ - -/* A (input) REAL array, dimension */ -/* (LDA,min(nq,K)) if VECT = 'Q' */ -/* (LDA,nq) if VECT = 'P' */ -/* The vectors which define the elementary reflectors H(i) and */ -/* G(i), whose products determine the matrices Q and P, as */ -/* returned by SGEBRD. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If VECT = 'Q', LDA >= max(1,nq); */ -/* if VECT = 'P', LDA >= max(1,min(nq,K)). */ - -/* TAU (input) REAL array, dimension (min(nq,K)) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i) or G(i) which determines Q or P, as returned */ -/* by SGEBRD in the array argument TAUQ or TAUP. */ - -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q */ -/* or P*C or P**T*C or C*P or C*P**T. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace/output) REAL 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - applyq = lsame_(vect, "Q"); - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q or P and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! applyq && ! lsame_(vect, "P")) { - *info = -1; - } else if (! left && ! lsame_(side, "R")) { - *info = -2; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*k < 0) { - *info = -6; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = 1, i__2 = min(nq,*k); - if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) { - *info = -8; - } else if (*ldc < max(1,*m)) { - *info = -11; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -13; - } - } - - if (*info == 0) { - if (applyq) { - if (left) { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__1, n, &i__2, &c_n1); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__1, &i__2, &c_n1); - } - } else { - if (left) { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, "SORMLQ", ch__1, &i__1, n, &i__2, &c_n1); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, "SORMLQ", ch__1, m, &i__1, &i__2, &c_n1); - } - } - lwkopt = max(1,nw) * nb; - work[1] = (real) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORMBR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - work[1] = 1.f; - if (*m == 0 || *n == 0) { - return 0; - } - - if (applyq) { - -/* Apply Q */ - - if (nq >= *k) { - -/* Q was determined by a call to SGEBRD with nq >= k */ - - sormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo); - } else if (nq > 1) { - -/* Q was determined by a call to SGEBRD with nq < k */ - - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - sormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] -, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); - } - } else { - -/* Apply P */ - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - if (nq > *k) { - -/* P was determined by a call to SGEBRD with nq > k */ - - sormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo); - } else if (nq > 1) { - -/* P was determined by a call to SGEBRD with nq <= k */ - - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - sormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, - &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & - iinfo); - } - } - work[1] = (real) lwkopt; - return 0; - -/* End of SORMBR */ - -} /* sormbr_ */ diff --git a/3rdparty/lapack/sorml2.c b/3rdparty/lapack/sorml2.c deleted file mode 100644 index 63a84c7..0000000 --- a/3rdparty/lapack/sorml2.c +++ /dev/null @@ -1,230 +0,0 @@ -/* sorml2.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 sorml2_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, ic, jc, mi, ni, nq; - real aii; - logical left; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, - integer *, real *, real *, integer *, real *), xerbla_( - char *, 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 */ -/* ======= */ - -/* SORML2 overwrites the general real m by n matrix C with */ - -/* Q * C if SIDE = 'L' and TRANS = 'N', or */ - -/* Q'* C if SIDE = 'L' and TRANS = 'T', or */ - -/* C * Q if SIDE = 'R' and TRANS = 'N', or */ - -/* C * Q' if SIDE = 'R' and TRANS = 'T', */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q' from the Left */ -/* = 'R': apply Q or Q' from the Right */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply Q (No transpose) */ -/* = 'T': apply Q' (Transpose) */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) REAL array, dimension */ -/* (LDA,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* SGELQF in the first k rows of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,K). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGELQF. */ - -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the m by n matrix C. */ -/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace) REAL array, dimension */ -/* (N) if SIDE = 'L', */ -/* (M) if SIDE = 'R' */ - -/* 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 arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,*k)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORML2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H(i) is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H(i) */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.f; - slarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1]); - a[i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of SORML2 */ - -} /* sorml2_ */ diff --git a/3rdparty/lapack/sormlq.c b/3rdparty/lapack/sormlq.c deleted file mode 100644 index cb4aefb..0000000 --- a/3rdparty/lapack/sormlq.c +++ /dev/null @@ -1,334 +0,0 @@ -/* sormlq.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 integer c__65 = 65; - -/* Subroutine */ int sormlq_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i__; - real t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; - logical left; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - extern /* Subroutine */ int sorml2_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *), slarfb_(char *, char *, char *, char * -, integer *, integer *, integer *, real *, integer *, real *, - integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *, - real *, integer *, real *, real *, integer *); - logical notran; - integer ldwork; - char transt[1]; - 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 */ -/* ======= */ - -/* SORMLQ overwrites the general real M-by-N matrix C with */ - -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q; */ -/* = 'T': Transpose, apply Q**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) REAL array, dimension */ -/* (LDA,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* SGELQF in the first k rows of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,K). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGELQF. */ - -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace/output) REAL 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,*k)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - -/* Determine the block size. NB may be at most NBMAX, where NBMAX */ -/* is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, "SORMLQ", ch__1, m, n, k, &c_n1); - nb = min(i__1,i__2); - lwkopt = max(1,nw) * nb; - work[1] = (real) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORMLQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.f; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, "SORMLQ", ch__1, m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - sorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__4 = nq - i__ + 1; - slarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], - lda, &tau[i__], t, &c__65); - if (left) { - -/* H or H' is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H or H' is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H or H' */ - - slarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ - + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], - ldc, &work[1], &ldwork); -/* L10: */ - } - } - work[1] = (real) lwkopt; - return 0; - -/* End of SORMLQ */ - -} /* sormlq_ */ diff --git a/3rdparty/lapack/sormql.c b/3rdparty/lapack/sormql.c deleted file mode 100644 index 8e4f247..0000000 --- a/3rdparty/lapack/sormql.c +++ /dev/null @@ -1,328 +0,0 @@ -/* sormql.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 integer c__65 = 65; - -/* Subroutine */ int sormql_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i__; - real t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws; - logical left; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - extern /* Subroutine */ int sorm2l_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *), slarfb_(char *, char *, char *, char * -, integer *, integer *, integer *, real *, integer *, real *, - integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *, - real *, integer *, real *, real *, integer *); - logical notran; - 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 */ -/* ======= */ - -/* SORMQL overwrites the general real M-by-N matrix C with */ - -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q; */ -/* = 'T': Transpose, apply Q**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) REAL array, dimension (LDA,K) */ -/* The i-th column must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* SGEQLF in the last k columns of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If SIDE = 'L', LDA >= max(1,M); */ -/* if SIDE = 'R', LDA >= max(1,N). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGEQLF. */ - -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace/output) REAL 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = max(1,*n); - } else { - nq = *n; - nw = max(1,*m); - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - - if (*info == 0) { - if (*m == 0 || *n == 0) { - lwkopt = 1; - } else { - -/* Determine the block size. NB may be at most NBMAX, where */ -/* NBMAX is used to define the local array T. */ - - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, "SORMQL", ch__1, m, n, k, &c_n1); - nb = min(i__1,i__2); - lwkopt = nw * nb; - } - work[1] = (real) lwkopt; - - if (*lwork < nw && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORMQL", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, "SORMQL", ch__1, m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - sorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__4 = nq - *k + i__ + ib - 1; - slarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] -, lda, &tau[i__], t, &c__65); - if (left) { - -/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */ - - mi = *m - *k + i__ + ib - 1; - } else { - -/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */ - - ni = *n - *k + i__ + ib - 1; - } - -/* Apply H or H' */ - - slarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[ - i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, & - work[1], &ldwork); -/* L10: */ - } - } - work[1] = (real) lwkopt; - return 0; - -/* End of SORMQL */ - -} /* sormql_ */ diff --git a/3rdparty/lapack/sormqr.c b/3rdparty/lapack/sormqr.c deleted file mode 100644 index a792f45..0000000 --- a/3rdparty/lapack/sormqr.c +++ /dev/null @@ -1,327 +0,0 @@ -/* sormqr.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 integer c__65 = 65; - -/* Subroutine */ int sormqr_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i__; - real t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; - logical left; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *), slarfb_(char *, char *, char *, char * -, integer *, integer *, integer *, real *, integer *, real *, - integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *, - real *, integer *, real *, real *, integer *); - logical notran; - 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 */ -/* ======= */ - -/* SORMQR overwrites the general real M-by-N matrix C with */ - -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* where Q is a real orthogonal matrix defined as the product of k */ -/* elementary reflectors */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N */ -/* if SIDE = 'R'. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q; */ -/* = 'T': Transpose, apply Q**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines */ -/* the matrix Q. */ -/* If SIDE = 'L', M >= K >= 0; */ -/* if SIDE = 'R', N >= K >= 0. */ - -/* A (input) REAL array, dimension (LDA,K) */ -/* The i-th column must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* SGEQRF in the first k columns of its array argument A. */ -/* A is modified by the routine but restored on exit. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If SIDE = 'L', LDA >= max(1,M); */ -/* if SIDE = 'R', LDA >= max(1,N). */ - -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SGEQRF. */ - -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace/output) REAL 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - -/* Determine the block size. NB may be at most NBMAX, where NBMAX */ -/* is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, "SORMQR", ch__1, m, n, k, &c_n1); - nb = min(i__1,i__2); - lwkopt = max(1,nw) * nb; - work[1] = (real) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SORMQR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.f; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, "SORMQR", ch__1, m, n, k, &c_n1); - nbmin = max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - sorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__4 = nq - i__ + 1; - slarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], t, &c__65) - ; - if (left) { - -/* H or H' is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H or H' is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H or H' */ - - slarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ - i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * - c_dim1], ldc, &work[1], &ldwork); -/* L10: */ - } - } - work[1] = (real) lwkopt; - return 0; - -/* End of SORMQR */ - -} /* sormqr_ */ diff --git a/3rdparty/lapack/sormtr.c b/3rdparty/lapack/sormtr.c deleted file mode 100644 index 2ef533a..0000000 --- a/3rdparty/lapack/sormtr.c +++ /dev/null @@ -1,295 +0,0 @@ -/* sormtr.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; - -/* Subroutine */ int sormtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, real *a, integer *lda, real *tau, real *c__, integer *ldc, - real *work, integer *lwork, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i1, i2, nb, mi, ni, nq, nw; - logical left; - extern logical lsame_(char *, char *); - integer iinfo; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int sormql_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *, integer *); - integer lwkopt; - logical lquery; - extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SORMTR overwrites the general real M-by-N matrix C with */ - -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': Q * C C * Q */ -/* TRANS = 'T': Q**T * C C * Q**T */ - -/* where Q is a real orthogonal matrix of order nq, with nq = m if */ -/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ -/* nq-1 elementary reflectors, as returned by SSYTRD: */ - -/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ - -/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A contains elementary reflectors */ -/* from SSYTRD; */ -/* = 'L': Lower triangle of A contains elementary reflectors */ -/* from SSYTRD. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q; */ -/* = 'T': Transpose, apply Q**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix C. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix C. N >= 0. */ - -/* A (input) REAL array, dimension */ -/* (LDA,M) if SIDE = 'L' */ -/* (LDA,N) if SIDE = 'R' */ -/* The vectors which define the elementary reflectors, as */ -/* returned by SSYTRD. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */ - -/* TAU (input) REAL array, dimension */ -/* (M-1) if SIDE = 'L' */ -/* (N-1) if SIDE = 'R' */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by SSYTRD. */ - -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace/output) REAL 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. */ -/* If SIDE = 'L', LWORK >= max(1,N); */ -/* if SIDE = 'R', LWORK >= max(1,M). */ -/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */ -/* LWORK >= M*NB if SIDE = 'R', 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 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. 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; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T")) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - if (upper) { - if (left) { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, "SORMQL", ch__1, &i__2, n, &i__3, &c_n1); - } else { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, "SORMQL", ch__1, m, &i__2, &i__3, &c_n1); - } - } else { - if (left) { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__2, n, &i__3, &c_n1); - } else { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = side; - i__1[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__2, &i__3, &c_n1); - } - } - lwkopt = max(1,nw) * nb; - work[1] = (real) lwkopt; - } - - if (*info != 0) { - i__2 = -(*info); - xerbla_("SORMTR", &i__2); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || nq == 1) { - work[1] = 1.f; - return 0; - } - - if (left) { - mi = *m - 1; - ni = *n; - } else { - mi = *m; - ni = *n - 1; - } - - if (upper) { - -/* Q was determined by a call to SSYTRD with UPLO = 'U' */ - - i__2 = nq - 1; - sormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & - tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo); - } else { - -/* Q was determined by a call to SSYTRD with UPLO = 'L' */ - - if (left) { - i1 = 2; - i2 = 1; - } else { - i1 = 1; - i2 = 2; - } - i__2 = nq - 1; - sormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & - c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); - } - work[1] = (real) lwkopt; - return 0; - -/* End of SORMTR */ - -} /* sormtr_ */ diff --git a/3rdparty/lapack/spotf2.c b/3rdparty/lapack/spotf2.c deleted file mode 100644 index ae8d93d..0000000 --- a/3rdparty/lapack/spotf2.c +++ /dev/null @@ -1,221 +0,0 @@ -/* spotf2.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 real c_b10 = -1.f; -static real c_b12 = 1.f; - -/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer j; - real ajj; - extern doublereal sdot_(integer *, real *, integer *, real *, integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), - sgemv_(char *, integer *, integer *, real *, real *, integer *, - real *, integer *, real *, real *, integer *); - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern logical sisnan_(real *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SPOTF2 computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U' * U , if UPLO = 'U', or */ -/* A = L * L', if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, 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. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U'*U or A = L*L'. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, the leading minor of order k is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. 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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SPOTF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute U(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j * a_dim1 + 1], &c__1, - &a[j * a_dim1 + 1], &c__1); - if (ajj <= 0.f || sisnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of row J. */ - - if (j < *n) { - i__2 = j - 1; - i__3 = *n - j; - sgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 - + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( - j + 1) * a_dim1], lda); - i__2 = *n - j; - r__1 = 1.f / ajj; - sscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute L(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j + a_dim1], lda, &a[j - + a_dim1], lda); - if (ajj <= 0.f || sisnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of column J. */ - - if (j < *n) { - i__2 = *n - j; - i__3 = j - 1; - sgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + - a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + - j * a_dim1], &c__1); - i__2 = *n - j; - r__1 = 1.f / ajj; - sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1); - } -/* L20: */ - } - } - goto L40; - -L30: - *info = j; - -L40: - return 0; - -/* End of SPOTF2 */ - -} /* spotf2_ */ diff --git a/3rdparty/lapack/spotrf.c b/3rdparty/lapack/spotrf.c deleted file mode 100644 index 3029f61..0000000 --- a/3rdparty/lapack/spotrf.c +++ /dev/null @@ -1,243 +0,0 @@ -/* spotrf.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 real c_b13 = -1.f; -static real c_b14 = 1.f; - -/* Subroutine */ int spotrf_(char *uplo, integer *n, real *a, integer *lda, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer j, jb, nb; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - logical upper; - extern /* Subroutine */ int strsm_(char *, char *, char *, char *, - integer *, integer *, real *, real *, integer *, real *, integer * -), ssyrk_(char *, char *, integer - *, integer *, real *, real *, integer *, real *, real *, integer * -), spotf2_(char *, integer *, real *, integer *, - integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, 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 */ -/* ======= */ - -/* SPOTRF computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the block version of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, 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. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= 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, the leading minor of order i is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. 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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SPOTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "SPOTRF", uplo, n, &c_n1, &c_n1, &c_n1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code. */ - - spotf2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code. */ - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - i__3 = j - 1; - ssyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j * - a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda); - spotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block row. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - sgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, & - c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) * - a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) * - a_dim1], lda); - i__3 = *n - j - jb + 1; - strsm_("Left", "Upper", "Transpose", "Non-unit", &jb, & - i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j - + jb) * a_dim1], lda); - } -/* L10: */ - } - - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__2 = *n; - i__1 = nb; - for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - i__3 = j - 1; - ssyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j + - a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda); - spotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block column. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, & - c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1], - lda, &c_b14, &a[j + jb + j * a_dim1], lda); - i__3 = *n - j - jb + 1; - strsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, & - jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb + - j * a_dim1], lda); - } -/* L20: */ - } - } - } - goto L40; - -L30: - *info = *info + j - 1; - -L40: - return 0; - -/* End of SPOTRF */ - -} /* spotrf_ */ diff --git a/3rdparty/lapack/spotri.c b/3rdparty/lapack/spotri.c deleted file mode 100644 index c098722..0000000 --- a/3rdparty/lapack/spotri.c +++ /dev/null @@ -1,124 +0,0 @@ -/* spotri.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 spotri_(char *uplo, integer *n, real *a, integer *lda, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - - /* Local variables */ - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *), slauum_( - char *, integer *, real *, integer *, integer *), strtri_( - char *, char *, integer *, real *, integer *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SPOTRI computes the inverse of a real symmetric positive definite */ -/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ -/* computed by SPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T, as computed by */ -/* SPOTRF. */ -/* On exit, the upper or lower triangle of the (symmetric) */ -/* inverse of A, overwriting the input factor U or L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= 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, the (i,i) element of the factor U or L is */ -/* zero, and the inverse could not be computed. */ - -/* ===================================================================== */ - -/* .. 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; - - /* Function Body */ - *info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SPOTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Invert the triangular Cholesky factor U or L. */ - - strtri_(uplo, "Non-unit", n, &a[a_offset], lda, info); - if (*info > 0) { - return 0; - } - -/* Form inv(U)*inv(U)' or inv(L)'*inv(L). */ - - slauum_(uplo, n, &a[a_offset], lda, info); - - return 0; - -/* End of SPOTRI */ - -} /* spotri_ */ diff --git a/3rdparty/lapack/spotrs.c b/3rdparty/lapack/spotrs.c deleted file mode 100644 index 21640ed..0000000 --- a/3rdparty/lapack/spotrs.c +++ /dev/null @@ -1,164 +0,0 @@ -/* spotrs.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 real c_b9 = 1.f; - -/* Subroutine */ int spotrs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *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 *); - logical upper; - extern /* Subroutine */ int strsm_(char *, char *, char *, char *, - integer *, integer *, real *, real *, integer *, real *, 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 */ -/* ======= */ - -/* SPOTRS solves a system of linear equations A*X = B with a symmetric */ -/* positive definite matrix A using the Cholesky factorization */ -/* A = U**T*U or A = L*L**T computed by SPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* 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) REAL array, dimension (LDA,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) REAL 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; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *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 = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SPOTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B where A = U'*U. */ - -/* Solve U'*X = B, overwriting B with X. */ - - strsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Solve U*X = B, overwriting B with X. */ - - strsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb); - } else { - -/* Solve A*X = B where A = L*L'. */ - -/* Solve L*X = B, overwriting B with X. */ - - strsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb); - -/* Solve L'*X = B, overwriting B with X. */ - - strsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb); - } - - return 0; - -/* End of SPOTRS */ - -} /* spotrs_ */ diff --git a/3rdparty/lapack/srot.c b/3rdparty/lapack/srot.c deleted file mode 100644 index e57d5ba..0000000 --- a/3rdparty/lapack/srot.c +++ /dev/null @@ -1,90 +0,0 @@ -/* srot.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 srot_(integer *n, real *sx, integer *incx, real *sy, - integer *incy, real *c__, real *s) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, ix, iy; - real stemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* applies a plane rotation. */ - -/* Further Details */ -/* =============== */ - -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ - /* Parameter adjustments */ - --sy; - --sx; - - /* 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__) { - stemp = *c__ * sx[ix] + *s * sy[iy]; - sy[iy] = *c__ * sy[iy] - *s * sx[ix]; - sx[ix] = stemp; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - -L20: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - stemp = *c__ * sx[i__] + *s * sy[i__]; - sy[i__] = *c__ * sy[i__] - *s * sx[i__]; - sx[i__] = stemp; -/* L30: */ - } - return 0; -} /* srot_ */ diff --git a/3rdparty/lapack/sscal.c b/3rdparty/lapack/sscal.c deleted file mode 100644 index 890967e..0000000 --- a/3rdparty/lapack/sscal.c +++ /dev/null @@ -1,95 +0,0 @@ -/* sscal.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 sscal_(integer *n, real *sa, real *sx, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, m, mp1, nincx; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* scales a vector by a constant. */ -/* uses unrolled loops for increment equal to 1. */ -/* 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 */ - --sx; - - /* Function Body */ - if (*n <= 0 || *incx <= 0) { - return 0; - } - 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) { - sx[i__] = *sa * sx[i__]; -/* L10: */ - } - return 0; - -/* code for increment equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__2 = m; - for (i__ = 1; i__ <= i__2; ++i__) { - sx[i__] = *sa * sx[i__]; -/* L30: */ - } - if (*n < 5) { - return 0; - } -L40: - mp1 = m + 1; - i__2 = *n; - for (i__ = mp1; i__ <= i__2; i__ += 5) { - sx[i__] = *sa * sx[i__]; - sx[i__ + 1] = *sa * sx[i__ + 1]; - sx[i__ + 2] = *sa * sx[i__ + 2]; - sx[i__ + 3] = *sa * sx[i__ + 3]; - sx[i__ + 4] = *sa * sx[i__ + 4]; -/* L50: */ - } - return 0; -} /* sscal_ */ diff --git a/3rdparty/lapack/sstebz.c b/3rdparty/lapack/sstebz.c deleted file mode 100644 index f13dc26..0000000 --- a/3rdparty/lapack/sstebz.c +++ /dev/null @@ -1,773 +0,0 @@ -/* sstebz.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 sstebz_(char *range, char *order, integer *n, real *vl, - real *vu, integer *il, integer *iu, real *abstol, real *d__, real *e, - integer *m, integer *nsplit, real *w, integer *iblock, integer * - isplit, real *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - real r__1, r__2, r__3, r__4, r__5; - - /* Builtin functions */ - double sqrt(doublereal), log(doublereal); - - /* Local variables */ - integer j, ib, jb, ie, je, nb; - real gl; - integer im, in; - real gu; - integer iw; - real wl, wu; - integer nwl; - real ulp, wlu, wul; - integer nwu; - real tmp1, tmp2; - integer iend, ioff, iout, itmp1, jdisc; - extern logical lsame_(char *, char *); - integer iinfo; - real atoli; - integer iwoff; - real bnorm; - integer itmax; - real wkill, rtoli, tnorm; - integer ibegin, irange, idiscl; - extern doublereal slamch_(char *); - real safemn; - integer idumma[1]; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - integer idiscu; - extern /* Subroutine */ int slaebz_(integer *, integer *, integer *, - integer *, integer *, integer *, real *, real *, real *, real *, - real *, real *, integer *, real *, real *, integer *, integer *, - real *, integer *, integer *); - integer iorder; - logical ncnvrg; - real pivmin; - logical toofew; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ -/* 8-18-00: Increase FUDGE factor for T3E (eca) */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSTEBZ computes the eigenvalues of a symmetric tridiagonal */ -/* matrix T. 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*1 */ -/* = '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*1 */ -/* = '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) REAL */ -/* VU (input) REAL */ -/* 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'. */ - -/* ABSTOL (input) REAL */ -/* The absolute tolerance for the eigenvalues. An eigenvalue */ -/* (or cluster) is considered to be located if it has been */ -/* determined to lie in an interval whose width is ABSTOL or */ -/* less. If ABSTOL is less than or equal to zero, then ULP*|T| */ -/* will be used, where |T| means the 1-norm of T. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */ - -/* D (input) REAL array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix T. */ - -/* E (input) REAL array, dimension (N-1) */ -/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */ - -/* M (output) INTEGER */ -/* The actual number of eigenvalues found. 0 <= M <= N. */ -/* (See also the description of INFO=2,3.) */ - -/* NSPLIT (output) INTEGER */ -/* The number of diagonal blocks in the matrix T. */ -/* 1 <= NSPLIT <= N. */ - -/* W (output) REAL array, dimension (N) */ -/* On exit, the first M elements of W will contain the */ -/* eigenvalues. (SSTEBZ may use the remaining N-M elements as */ -/* workspace.) */ - -/* 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. (SSTEBZ may use the remaining N-M elements as */ -/* workspace.) */ - -/* ISPLIT (output) 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.) */ - -/* WORK (workspace) REAL 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 */ -/* =================== */ - -/* RELFAC REAL, default = 2.0e0 */ -/* The relative tolerance. An interval (a,b] lies within */ -/* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), */ -/* where "ulp" is the machine precision (distance from 1 to */ -/* the next larger floating point number.) */ - -/* FUDGE REAL, 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. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --iwork; - --work; - --isplit; - --iblock; - --w; - --e; - --d__; - - /* 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; - } - -/* Decode ORDER */ - - if (lsame_(order, "B")) { - iorder = 2; - } else if (lsame_(order, "E")) { - iorder = 1; - } else { - iorder = 0; - } - -/* Check for Errors */ - - if (irange <= 0) { - *info = -1; - } else if (iorder <= 0) { - *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) { - i__1 = -(*info); - xerbla_("SSTEBZ", &i__1); - return 0; - } - -/* Initialize error flags */ - - *info = 0; - ncnvrg = FALSE_; - toofew = FALSE_; - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - -/* Simplifications: */ - - if (irange == 3 && *il == 1 && *iu == *n) { - irange = 1; - } - -/* Get machine constants */ -/* NB is the minimum vector length for vector bisection, or 0 */ -/* if only scalar is to be done. */ - - safemn = slamch_("S"); - ulp = slamch_("P"); - rtoli = ulp * 2.f; - nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1); - if (nb <= 1) { - nb = 0; - } - -/* Special Case when N=1 */ - - if (*n == 1) { - *nsplit = 1; - isplit[1] = 1; - if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) { - *m = 0; - } else { - w[1] = d__[1]; - iblock[1] = 1; - *m = 1; - } - return 0; - } - -/* Compute Splitting Points */ - - *nsplit = 1; - work[*n] = 0.f; - pivmin = 1.f; - -/* DIR$ NOVECTOR */ - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing 2nd power */ - r__1 = e[j - 1]; - tmp1 = r__1 * r__1; -/* Computing 2nd power */ - r__2 = ulp; - if ((r__1 = d__[j] * d__[j - 1], dabs(r__1)) * (r__2 * r__2) + safemn - > tmp1) { - isplit[*nsplit] = j - 1; - ++(*nsplit); - work[j - 1] = 0.f; - } else { - work[j - 1] = tmp1; - pivmin = dmax(pivmin,tmp1); - } -/* L10: */ - } - isplit[*nsplit] = *n; - pivmin *= safemn; - -/* Compute Interval and ATOLI */ - - if (irange == 3) { - -/* RANGE='I': Compute the interval containing eigenvalues */ -/* IL through IU. */ - -/* Compute Gershgorin interval for entire (split) matrix */ -/* and use it as the initial interval */ - - gu = d__[1]; - gl = d__[1]; - tmp1 = 0.f; - - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - tmp2 = sqrt(work[j]); -/* Computing MAX */ - r__1 = gu, r__2 = d__[j] + tmp1 + tmp2; - gu = dmax(r__1,r__2); -/* Computing MIN */ - r__1 = gl, r__2 = d__[j] - tmp1 - tmp2; - gl = dmin(r__1,r__2); - tmp1 = tmp2; -/* L20: */ - } - -/* Computing MAX */ - r__1 = gu, r__2 = d__[*n] + tmp1; - gu = dmax(r__1,r__2); -/* Computing MIN */ - r__1 = gl, r__2 = d__[*n] - tmp1; - gl = dmin(r__1,r__2); -/* Computing MAX */ - r__1 = dabs(gl), r__2 = dabs(gu); - tnorm = dmax(r__1,r__2); - gl = gl - tnorm * 2.1f * ulp * *n - pivmin * 4.2000000000000002f; - gu = gu + tnorm * 2.1f * ulp * *n + pivmin * 2.1f; - -/* Compute Iteration parameters */ - - itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.f)) + - 2; - if (*abstol <= 0.f) { - atoli = ulp * tnorm; - } else { - atoli = *abstol; - } - - 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; - - slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin, - &d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n - + 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo); - - 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]; - } - - if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) { - *info = 4; - return 0; - } - } else { - -/* RANGE='A' or 'V' -- Set ATOLI */ - -/* Computing MAX */ - r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = d__[*n], dabs(r__1)) - + (r__2 = e[*n - 1], dabs(r__2)); - tnorm = dmax(r__3,r__4); - - i__1 = *n - 1; - for (j = 2; j <= i__1; ++j) { -/* Computing MAX */ - r__4 = tnorm, r__5 = (r__1 = d__[j], dabs(r__1)) + (r__2 = e[j - - 1], dabs(r__2)) + (r__3 = e[j], dabs(r__3)); - tnorm = dmax(r__4,r__5); -/* L30: */ - } - - if (*abstol <= 0.f) { - atoli = ulp * tnorm; - } else { - atoli = *abstol; - } - - if (irange == 2) { - wl = *vl; - wu = *vu; - } else { - wl = 0.f; - wu = 0.f; - } - } - -/* 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 (jb = 1; jb <= i__1; ++jb) { - ioff = iend; - ibegin = ioff + 1; - iend = isplit[jb]; - in = iend - ioff; - - if (in == 1) { - -/* Special Case -- IN=1 */ - - if (irange == 1 || wl >= d__[ibegin] - pivmin) { - ++nwl; - } - if (irange == 1 || wu >= d__[ibegin] - pivmin) { - ++nwu; - } - if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin] - - pivmin) { - ++(*m); - w[*m] = d__[ibegin]; - iblock[*m] = jb; - } - } else { - -/* General Case -- IN > 1 */ - -/* Compute Gershgorin Interval */ -/* and use it as the initial interval */ - - gu = d__[ibegin]; - gl = d__[ibegin]; - tmp1 = 0.f; - - i__2 = iend - 1; - for (j = ibegin; j <= i__2; ++j) { - tmp2 = (r__1 = e[j], dabs(r__1)); -/* Computing MAX */ - r__1 = gu, r__2 = d__[j] + tmp1 + tmp2; - gu = dmax(r__1,r__2); -/* Computing MIN */ - r__1 = gl, r__2 = d__[j] - tmp1 - tmp2; - gl = dmin(r__1,r__2); - tmp1 = tmp2; -/* L40: */ - } - -/* Computing MAX */ - r__1 = gu, r__2 = d__[iend] + tmp1; - gu = dmax(r__1,r__2); -/* Computing MIN */ - r__1 = gl, r__2 = d__[iend] - tmp1; - gl = dmin(r__1,r__2); -/* Computing MAX */ - r__1 = dabs(gl), r__2 = dabs(gu); - bnorm = dmax(r__1,r__2); - gl = gl - bnorm * 2.1f * ulp * in - pivmin * 2.1f; - gu = gu + bnorm * 2.1f * ulp * in + pivmin * 2.1f; - -/* Compute ATOLI for the current submatrix */ - - if (*abstol <= 0.f) { -/* Computing MAX */ - r__1 = dabs(gl), r__2 = dabs(gu); - atoli = ulp * dmax(r__1,r__2); - } else { - atoli = *abstol; - } - - if (irange > 1) { - if (gu < wl) { - nwl += in; - nwu += in; - goto L70; - } - gl = dmax(gl,wl); - gu = dmin(gu,wu); - if (gl >= gu) { - goto L70; - } - } - -/* Set Up Initial Interval */ - - work[*n + 1] = gl; - work[*n + in + 1] = gu; - slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, & - pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, & - work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], & - w[*m + 1], &iblock[*m + 1], &iinfo); - - nwl += iwork[1]; - nwu += iwork[in + 1]; - iwoff = *m - iwork[1]; - -/* Compute Eigenvalues */ - - itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log( - 2.f)) + 2; - slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, & - pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, & - work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], - &w[*m + 1], &iblock[*m + 1], &iinfo); - -/* Copy Eigenvalues Into W and IBLOCK */ -/* Use -JB for block number for unconverged eigenvalues. */ - - i__2 = iout; - for (j = 1; j <= i__2; ++j) { - tmp1 = (work[j + *n] + work[j + in + *n]) * .5f; - -/* Flag non-convergence. */ - - if (j > iout - iinfo) { - ncnvrg = TRUE_; - ib = -jb; - } else { - ib = jb; - } - i__3 = iwork[j + in] + iwoff; - for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) { - w[je] = tmp1; - 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) { - im = 0; - idiscl = *il - 1 - nwl; - idiscu = nwu - *iu; - - if (idiscl > 0 || idiscu > 0) { - i__1 = *m; - for (je = 1; je <= i__1; ++je) { - if (w[je] <= wlu && idiscl > 0) { - --idiscl; - } else if (w[je] >= wul && idiscu > 0) { - --idiscu; - } else { - ++im; - w[im] = w[je]; - iblock[im] = iblock[je]; - } -/* L80: */ - } - *m = im; - } - if (idiscl > 0 || idiscu > 0) { - -/* Code to deal with effects of bad arithmetic: */ -/* 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 simply finding the smallest/largest */ -/* eigenvalue(s). */ - -/* (If N(w) is monotone non-decreasing, this should never */ -/* happen.) */ - - 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: */ - } - } - im = 0; - i__1 = *m; - for (je = 1; je <= i__1; ++je) { - if (iblock[je] != 0) { - ++im; - w[im] = w[je]; - iblock[im] = iblock[je]; - } -/* L130: */ - } - *m = im; - } - if (idiscl < 0 || idiscu < 0) { - 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 (iorder == 1 && *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) { - itmp1 = iblock[ie]; - w[ie] = w[je]; - iblock[ie] = iblock[je]; - w[je] = tmp1; - iblock[je] = itmp1; - } -/* L150: */ - } - } - - *info = 0; - if (ncnvrg) { - ++(*info); - } - if (toofew) { - *info += 2; - } - return 0; - -/* End of SSTEBZ */ - -} /* sstebz_ */ diff --git a/3rdparty/lapack/sstein.c b/3rdparty/lapack/sstein.c deleted file mode 100644 index 365e40f..0000000 --- a/3rdparty/lapack/sstein.c +++ /dev/null @@ -1,449 +0,0 @@ -/* sstein.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 integer c_n1 = -1; - -/* Subroutine */ int sstein_(integer *n, real *d__, real *e, integer *m, real - *w, integer *iblock, integer *isplit, real *z__, integer *ldz, real * - work, integer *iwork, integer *ifail, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2, i__3; - real r__1, r__2, r__3, r__4, r__5; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, b1, j1, bn; - real xj, scl, eps, ctr, sep, nrm, tol; - integer its; - real xjm, eps1; - integer jblk, nblk, jmax; - extern doublereal sdot_(integer *, real *, integer *, real *, integer *), - snrm2_(integer *, real *, integer *); - integer iseed[4], gpind, iinfo; - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - extern doublereal sasum_(integer *, real *, integer *); - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *); - real ortol; - extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, - real *, integer *); - integer indrv1, indrv2, indrv3, indrv4, indrv5; - extern doublereal slamch_(char *); - extern /* Subroutine */ int xerbla_(char *, integer *), slagtf_( - integer *, real *, real *, real *, real *, real *, real *, - integer *, integer *); - integer nrmchk; - extern integer isamax_(integer *, real *, integer *); - extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *, - real *, real *, integer *, real *, real *, integer *); - integer blksiz; - real onenrm, pertol; - extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real - *); - real stpcrt; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSTEIN computes the eigenvectors of a real symmetric tridiagonal */ -/* matrix T corresponding to specified eigenvalues, using inverse */ -/* iteration. */ - -/* The maximum number of iterations allowed for each eigenvector is */ -/* specified by an internal parameter MAXITS (currently set to 5). */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input) REAL array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix T. */ - -/* E (input) REAL array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the tridiagonal matrix */ -/* T, in elements 1 to N-1. */ - -/* M (input) INTEGER */ -/* The number of eigenvectors to be found. 0 <= M <= N. */ - -/* W (input) REAL array, dimension (N) */ -/* The first M elements of W contain the 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 SSTEBZ with ORDER = 'B' is expected here. ) */ - -/* IBLOCK (input) INTEGER array, dimension (N) */ -/* The submatrix indices associated with the corresponding */ -/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */ -/* the first submatrix from the top, =2 if W(i) belongs to */ -/* the second submatrix, etc. ( The output array IBLOCK */ -/* from SSTEBZ is expected here. ) */ - -/* 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. */ -/* ( The output array ISPLIT from SSTEBZ is expected here. ) */ - -/* Z (output) REAL array, dimension (LDZ, M) */ -/* The computed eigenvectors. The eigenvector associated */ -/* with the eigenvalue W(i) is stored in the i-th column of */ -/* Z. Any vector which fails to converge is set to its current */ -/* iterate after MAXITS iterations. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= max(1,N). */ - -/* WORK (workspace) REAL array, dimension (5*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* IFAIL (output) INTEGER array, dimension (M) */ -/* On normal exit, all elements of IFAIL are zero. */ -/* If one or more eigenvectors fail to converge after */ -/* MAXITS iterations, then their indices are stored in */ -/* array IFAIL. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, then i eigenvectors failed to converge */ -/* in MAXITS iterations. Their indices are stored in */ -/* array IFAIL. */ - -/* Internal Parameters */ -/* =================== */ - -/* MAXITS INTEGER, default = 5 */ -/* The maximum number of iterations performed. */ - -/* EXTRA INTEGER, default = 2 */ -/* The number of iterations performed after norm growth */ -/* criterion is satisfied, should be at least 1. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --w; - --iblock; - --isplit; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - *info = 0; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - ifail[i__] = 0; -/* L10: */ - } - - if (*n < 0) { - *info = -1; - } else if (*m < 0 || *m > *n) { - *info = -4; - } else if (*ldz < max(1,*n)) { - *info = -9; - } else { - i__1 = *m; - for (j = 2; j <= i__1; ++j) { - if (iblock[j] < iblock[j - 1]) { - *info = -6; - goto L30; - } - if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { - *info = -5; - goto L30; - } -/* L20: */ - } -L30: - ; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SSTEIN", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *m == 0) { - return 0; - } else if (*n == 1) { - z__[z_dim1 + 1] = 1.f; - return 0; - } - -/* Get machine constants. */ - - eps = slamch_("Precision"); - -/* Initialize seed for random number generator SLARNV. */ - - for (i__ = 1; i__ <= 4; ++i__) { - iseed[i__ - 1] = 1; -/* L40: */ - } - -/* Initialize pointers. */ - - indrv1 = 0; - indrv2 = indrv1 + *n; - indrv3 = indrv2 + *n; - indrv4 = indrv3 + *n; - indrv5 = indrv4 + *n; - -/* Compute eigenvectors of matrix blocks. */ - - j1 = 1; - i__1 = iblock[*m]; - for (nblk = 1; nblk <= i__1; ++nblk) { - -/* Find starting and ending indices of block nblk. */ - - if (nblk == 1) { - b1 = 1; - } else { - b1 = isplit[nblk - 1] + 1; - } - bn = isplit[nblk]; - blksiz = bn - b1 + 1; - if (blksiz == 1) { - goto L60; - } - gpind = b1; - -/* Compute reorthogonalization criterion and stopping criterion. */ - - onenrm = (r__1 = d__[b1], dabs(r__1)) + (r__2 = e[b1], dabs(r__2)); -/* Computing MAX */ - r__3 = onenrm, r__4 = (r__1 = d__[bn], dabs(r__1)) + (r__2 = e[bn - 1] - , dabs(r__2)); - onenrm = dmax(r__3,r__4); - i__2 = bn - 1; - for (i__ = b1 + 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - r__4 = onenrm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 = e[ - i__ - 1], dabs(r__2)) + (r__3 = e[i__], dabs(r__3)); - onenrm = dmax(r__4,r__5); -/* L50: */ - } - ortol = onenrm * .001f; - - stpcrt = sqrt(.1f / blksiz); - -/* Loop through eigenvalues of block nblk. */ - -L60: - jblk = 0; - i__2 = *m; - for (j = j1; j <= i__2; ++j) { - if (iblock[j] != nblk) { - j1 = j; - goto L160; - } - ++jblk; - xj = w[j]; - -/* Skip all the work if the block size is one. */ - - if (blksiz == 1) { - work[indrv1 + 1] = 1.f; - goto L120; - } - -/* If eigenvalues j and j-1 are too close, add a relatively */ -/* small perturbation. */ - - if (jblk > 1) { - eps1 = (r__1 = eps * xj, dabs(r__1)); - pertol = eps1 * 10.f; - sep = xj - xjm; - if (sep < pertol) { - xj = xjm + pertol; - } - } - - its = 0; - nrmchk = 0; - -/* Get random starting vector. */ - - slarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]); - -/* Copy the matrix T so it won't be destroyed in factorization. */ - - scopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1); - i__3 = blksiz - 1; - scopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1); - i__3 = blksiz - 1; - scopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1); - -/* Compute LU factors with partial pivoting ( PT = LU ) */ - - tol = 0.f; - slagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[ - indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo); - -/* Update iteration count. */ - -L70: - ++its; - if (its > 5) { - goto L100; - } - -/* Normalize and scale the righthand side vector Pb. */ - -/* Computing MAX */ - r__2 = eps, r__3 = (r__1 = work[indrv4 + blksiz], dabs(r__1)); - scl = blksiz * onenrm * dmax(r__2,r__3) / sasum_(&blksiz, &work[ - indrv1 + 1], &c__1); - sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); - -/* Solve the system LU = Pb. */ - - slagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], & - work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[ - indrv1 + 1], &tol, &iinfo); - -/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */ -/* close enough. */ - - if (jblk == 1) { - goto L90; - } - if ((r__1 = xj - xjm, dabs(r__1)) > ortol) { - gpind = j; - } - if (gpind != j) { - i__3 = j - 1; - for (i__ = gpind; i__ <= i__3; ++i__) { - ctr = -sdot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 + - i__ * z_dim1], &c__1); - saxpy_(&blksiz, &ctr, &z__[b1 + i__ * z_dim1], &c__1, & - work[indrv1 + 1], &c__1); -/* L80: */ - } - } - -/* Check the infinity norm of the iterate. */ - -L90: - jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1); - nrm = (r__1 = work[indrv1 + jmax], dabs(r__1)); - -/* Continue for additional iterations after norm reaches */ -/* stopping criterion. */ - - if (nrm < stpcrt) { - goto L70; - } - ++nrmchk; - if (nrmchk < 3) { - goto L70; - } - - goto L110; - -/* If stopping criterion was not satisfied, update info and */ -/* store eigenvector number in array ifail. */ - -L100: - ++(*info); - ifail[*info] = j; - -/* Accept iterate as jth eigenvector. */ - -L110: - scl = 1.f / snrm2_(&blksiz, &work[indrv1 + 1], &c__1); - jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1); - if (work[indrv1 + jmax] < 0.f) { - scl = -scl; - } - sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); -L120: - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - z__[i__ + j * z_dim1] = 0.f; -/* L130: */ - } - i__3 = blksiz; - for (i__ = 1; i__ <= i__3; ++i__) { - z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__]; -/* L140: */ - } - -/* Save the shift to check eigenvalue spacing at next */ -/* iteration. */ - - xjm = xj; - -/* L150: */ - } -L160: - ; - } - - return 0; - -/* End of SSTEIN */ - -} /* sstein_ */ diff --git a/3rdparty/lapack/sstemr.c b/3rdparty/lapack/sstemr.c deleted file mode 100644 index c4936e2..0000000 --- a/3rdparty/lapack/sstemr.c +++ /dev/null @@ -1,726 +0,0 @@ -/* sstemr.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 real c_b18 = .003f; - -/* Subroutine */ int sstemr_(char *jobz, char *range, integer *n, real *d__, - real *e, real *vl, real *vu, integer *il, integer *iu, integer *m, - real *w, real *z__, integer *ldz, integer *nzc, integer *isuppz, - logical *tryrac, real *work, integer *lwork, integer *iwork, integer * - liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j; - real r1, r2; - integer jj; - real cs; - integer in; - real sn, wl, wu; - integer iil, iiu; - real eps, tmp; - integer indd, iend, jblk, wend; - real rmin, rmax; - integer itmp; - real tnrm; - integer inde2; - extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *) - ; - integer itmp2; - real rtol1, rtol2, scale; - integer indgp; - extern logical lsame_(char *, char *); - integer iinfo; - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - integer iindw, ilast, lwmin; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), sswap_(integer *, real *, integer *, real *, integer * -); - logical wantz; - extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real * -, real *, real *); - logical alleig; - integer ibegin; - logical indeig; - integer iindbl; - logical valeig; - extern doublereal slamch_(char *); - integer wbegin; - real safmin; - extern /* Subroutine */ int xerbla_(char *, integer *); - real bignum; - integer inderr, iindwk, indgrs, offset; - extern /* Subroutine */ int slarrc_(char *, integer *, real *, real *, - real *, real *, real *, integer *, integer *, integer *, integer * -), slarre_(char *, integer *, real *, real *, integer *, - integer *, real *, real *, real *, real *, real *, real *, - integer *, integer *, integer *, real *, real *, real *, integer * -, integer *, real *, real *, real *, integer *, integer *) - ; - real thresh; - integer iinspl, indwrk, ifirst, liwmin, nzcmin; - real pivmin; - extern doublereal slanst_(char *, integer *, real *, real *); - extern /* Subroutine */ int slarrj_(integer *, real *, real *, integer *, - integer *, real *, integer *, real *, real *, real *, integer *, - real *, real *, integer *), slarrr_(integer *, real *, real *, - integer *); - integer nsplit; - extern /* Subroutine */ int slarrv_(integer *, real *, real *, real *, - real *, real *, integer *, integer *, integer *, integer *, real * -, real *, real *, real *, real *, real *, integer *, integer *, - real *, real *, integer *, integer *, real *, integer *, integer * -); - real smlnum; - extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); - logical lquery, zquery; - - -/* -- LAPACK computational routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSTEMR computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ -/* a well defined set of pairwise different real eigenvalues, the corresponding */ -/* real eigenvectors are pairwise orthogonal. */ - -/* The spectrum may be computed either completely or partially by specifying */ -/* either an interval (VL,VU] or a range of indices IL:IU for the desired */ -/* eigenvalues. */ - -/* Depending on the number of desired eigenvalues, these are computed either */ -/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */ -/* computed by the use of various suitable L D L^T factorizations near clusters */ -/* of close eigenvalues (referred to as RRRs, Relatively Robust */ -/* Representations). An informal sketch of the algorithm follows. */ - -/* For each unreduced block (submatrix) of T, */ -/* (a) Compute T - sigma I = L D L^T, so that L and D */ -/* define all the wanted eigenvalues to high relative accuracy. */ -/* This means that small relative changes in the entries of D and L */ -/* cause only small relative changes in the eigenvalues and */ -/* eigenvectors. The standard (unfactored) representation of the */ -/* tridiagonal matrix T does not have this property in general. */ -/* (b) Compute the eigenvalues to suitable accuracy. */ -/* If the eigenvectors are desired, the algorithm attains full */ -/* accuracy of the computed eigenvalues only right before */ -/* the corresponding vectors have to be computed, see steps c) and d). */ -/* (c) For each cluster of close eigenvalues, select a new */ -/* shift close to the cluster, find a new factorization, and refine */ -/* the shifted eigenvalues to suitable accuracy. */ -/* (d) For each eigenvalue with a large enough relative separation compute */ -/* the corresponding eigenvector by forming a rank revealing twisted */ -/* factorization. Go back to (c) for any clusters that remain. */ - -/* For more details, see: */ -/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* 2004. Also LAPACK Working Note 154. */ -/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* tridiagonal eigenvalue/eigenvector problem", */ -/* Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* UC Berkeley, May 1997. */ - -/* Notes: */ -/* 1.SSTEMR works only on machines which follow IEEE-754 */ -/* floating-point standard in their handling of infinities and NaNs. */ -/* This permits the use of efficient inner loops avoiding a check for */ -/* zero divisors. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) REAL array, dimension (N) */ -/* On entry, the N diagonal elements of the tridiagonal matrix */ -/* T. On exit, D is overwritten. */ - -/* E (input/output) REAL array, dimension (N) */ -/* On entry, the (N-1) subdiagonal elements of the tridiagonal */ -/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */ -/* input, but is used internally as workspace. */ -/* On exit, E is overwritten. */ - -/* VL (input) REAL */ -/* VU (input) REAL */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. 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. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) REAL array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */ -/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix T */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and can be computed with a workspace */ -/* query by setting NZC = -1, see below. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', then LDZ >= max(1,N). */ - -/* NZC (input) INTEGER */ -/* The number of eigenvectors to be held in the array Z. */ -/* If RANGE = 'A', then NZC >= max(1,N). */ -/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */ -/* If RANGE = 'I', then NZC >= IU-IL+1. */ -/* If NZC = -1, then a workspace query is assumed; the */ -/* routine calculates the number of columns of the array Z that */ -/* are needed to hold the eigenvectors. */ -/* This value is returned as the first entry of the Z array, and */ -/* no error message related to NZC is issued by XERBLA. */ - -/* 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 computed eigenvector */ -/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */ -/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ - -/* TRYRAC (input/output) LOGICAL */ -/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */ -/* the tridiagonal matrix defines its eigenvalues to high relative */ -/* accuracy. If so, the code uses relative-accuracy preserving */ -/* algorithms that might be (a bit) slower depending on the matrix. */ -/* If the matrix does not define its eigenvalues to high relative */ -/* accuracy, the code can uses possibly faster algorithms. */ -/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */ -/* relatively accurate eigenvalues and can use the fastest possible */ -/* techniques. */ -/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */ -/* does not define its eigenvalues to high relative accuracy. */ - -/* WORK (workspace/output) REAL array, dimension (LWORK) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal */ -/* (and minimal) LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,18*N) */ -/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */ -/* 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/output) INTEGER array, dimension (LIWORK) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */ -/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */ -/* if only the eigenvalues are to be computed. */ -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* On exit, INFO */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = 1X, internal error in SLARRE, */ -/* if INFO = 2X, internal error in SLARRV. */ -/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ -/* the nonzero error code returned by SLARRE or */ -/* SLARRV, respectively. */ - - -/* 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 .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - lquery = *lwork == -1 || *liwork == -1; - zquery = *nzc == -1; -/* SSTEMR needs WORK of size 6*N, IWORK of size 3*N. */ -/* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N. */ -/* Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N. */ - if (wantz) { - lwmin = *n * 18; - liwmin = *n * 10; - } else { -/* need less workspace if only the eigenvalues are wanted */ - lwmin = *n * 12; - liwmin = *n << 3; - } - wl = 0.f; - wu = 0.f; - iil = 0; - iiu = 0; - if (valeig) { -/* We do not reference VL, VU in the cases RANGE = 'I','A' */ -/* The interval (WL, WU] contains all the wanted eigenvalues. */ -/* It is either given by the user or computed in SLARRE. */ - wl = *vl; - wu = *vu; - } else if (indeig) { -/* We do not reference IL, IU in the cases RANGE = 'V','A' */ - iil = *il; - iiu = *iu; - } - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (valeig && *n > 0 && wu <= wl) { - *info = -7; - } else if (indeig && (iil < 1 || iil > *n)) { - *info = -8; - } else if (indeig && (iiu < iil || iiu > *n)) { - *info = -9; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -13; - } else if (*lwork < lwmin && ! lquery) { - *info = -17; - } else if (*liwork < liwmin && ! lquery) { - *info = -19; - } - -/* Get machine constants. */ - - safmin = slamch_("Safe minimum"); - eps = slamch_("Precision"); - smlnum = safmin / eps; - bignum = 1.f / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin)); - rmax = dmin(r__1,r__2); - - if (*info == 0) { - work[1] = (real) lwmin; - iwork[1] = liwmin; - - if (wantz && alleig) { - nzcmin = *n; - } else if (wantz && valeig) { - slarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, & - itmp2, info); - } else if (wantz && indeig) { - nzcmin = iiu - iil + 1; - } else { -/* WANTZ .EQ. FALSE. */ - nzcmin = 0; - } - if (zquery && *info == 0) { - z__[z_dim1 + 1] = (real) nzcmin; - } else if (*nzc < nzcmin && ! zquery) { - *info = -14; - } - } - if (*info != 0) { - - i__1 = -(*info); - xerbla_("SSTEMR", &i__1); - - return 0; - } else if (lquery || zquery) { - return 0; - } - -/* Handle N = 0, 1, and 2 cases immediately */ - - *m = 0; - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (alleig || indeig) { - *m = 1; - w[1] = d__[1]; - } else { - if (wl < d__[1] && wu >= d__[1]) { - *m = 1; - w[1] = d__[1]; - } - } - if (wantz && ! zquery) { - z__[z_dim1 + 1] = 1.f; - isuppz[1] = 1; - isuppz[2] = 1; - } - return 0; - } - - if (*n == 2) { - if (! wantz) { - slae2_(&d__[1], &e[1], &d__[2], &r1, &r2); - } else if (wantz && ! zquery) { - slaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn); - } - if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) { - ++(*m); - w[*m] = r2; - if (wantz && ! zquery) { - z__[*m * z_dim1 + 1] = -sn; - z__[*m * z_dim1 + 2] = cs; -/* Note: At most one of SN and CS can be zero. */ - if (sn != 0.f) { - if (cs != 0.f) { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 2; - } else { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 1; - } - } else { - isuppz[(*m << 1) - 1] = 2; - isuppz[*m * 2] = 2; - } - } - } - if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) { - ++(*m); - w[*m] = r1; - if (wantz && ! zquery) { - z__[*m * z_dim1 + 1] = cs; - z__[*m * z_dim1 + 2] = sn; -/* Note: At most one of SN and CS can be zero. */ - if (sn != 0.f) { - if (cs != 0.f) { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 2; - } else { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 1; - } - } else { - isuppz[(*m << 1) - 1] = 2; - isuppz[*m * 2] = 2; - } - } - } - return 0; - } -/* Continue with general N */ - indgrs = 1; - inderr = (*n << 1) + 1; - indgp = *n * 3 + 1; - indd = (*n << 2) + 1; - inde2 = *n * 5 + 1; - indwrk = *n * 6 + 1; - - iinspl = 1; - iindbl = *n + 1; - iindw = (*n << 1) + 1; - iindwk = *n * 3 + 1; - -/* Scale matrix to allowable range, if necessary. */ -/* The allowable range is related to the PIVMIN parameter; see the */ -/* comments in SLARRD. The preference for scaling small values */ -/* up is heuristic; we expect users' matrices not to be close to the */ -/* RMAX threshold. */ - - scale = 1.f; - tnrm = slanst_("M", n, &d__[1], &e[1]); - if (tnrm > 0.f && tnrm < rmin) { - scale = rmin / tnrm; - } else if (tnrm > rmax) { - scale = rmax / tnrm; - } - if (scale != 1.f) { - sscal_(n, &scale, &d__[1], &c__1); - i__1 = *n - 1; - sscal_(&i__1, &scale, &e[1], &c__1); - tnrm *= scale; - if (valeig) { -/* If eigenvalues in interval have to be found, */ -/* scale (WL, WU] accordingly */ - wl *= scale; - wu *= scale; - } - } - -/* Compute the desired eigenvalues of the tridiagonal after splitting */ -/* into smaller subblocks if the corresponding off-diagonal elements */ -/* are small */ -/* THRESH is the splitting parameter for SLARRE */ -/* A negative THRESH forces the old splitting criterion based on the */ -/* size of the off-diagonal. A positive THRESH switches to splitting */ -/* which preserves relative accuracy. */ - - if (*tryrac) { -/* Test whether the matrix warrants the more expensive relative approach. */ - slarrr_(n, &d__[1], &e[1], &iinfo); - } else { -/* The user does not care about relative accurately eigenvalues */ - iinfo = -1; - } -/* Set the splitting criterion */ - if (iinfo == 0) { - thresh = eps; - } else { - thresh = -eps; -/* relative accuracy is desired but T does not guarantee it */ - *tryrac = FALSE_; - } - - if (*tryrac) { -/* Copy original diagonal, needed to guarantee relative accuracy */ - scopy_(n, &d__[1], &c__1, &work[indd], &c__1); - } -/* Store the squares of the offdiagonal values of T */ - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing 2nd power */ - r__1 = e[j]; - work[inde2 + j - 1] = r__1 * r__1; -/* L5: */ - } -/* Set the tolerance parameters for bisection */ - if (! wantz) { -/* SLARRE computes the eigenvalues to full precision. */ - rtol1 = eps * 4.f; - rtol2 = eps * 4.f; - } else { -/* SLARRE computes the eigenvalues to less than full precision. */ -/* SLARRV will refine the eigenvalue approximations, and we can */ -/* need less accurate initial bisection in SLARRE. */ -/* Note: these settings do only affect the subset case and SLARRE */ -/* Computing MAX */ - r__1 = sqrt(eps) * .05f, r__2 = eps * 4.f; - rtol1 = dmax(r__1,r__2); -/* Computing MAX */ - r__1 = sqrt(eps) * .005f, r__2 = eps * 4.f; - rtol2 = dmax(r__1,r__2); - } - slarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], & - rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[ - inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[ - indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo); - if (iinfo != 0) { - *info = abs(iinfo) + 10; - return 0; - } -/* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired */ -/* part of the spectrum. All desired eigenvalues are contained in */ -/* (WL,WU] */ - if (wantz) { - -/* Compute the desired eigenvectors corresponding to the computed */ -/* eigenvalues */ - - slarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, & - c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[ - indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[ - z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], & - iinfo); - if (iinfo != 0) { - *info = abs(iinfo) + 20; - return 0; - } - } else { -/* SLARRE computes eigenvalues of the (shifted) root representation */ -/* SLARRV returns the eigenvalues of the unshifted matrix. */ -/* However, if the eigenvectors are not desired by the user, we need */ -/* to apply the corresponding shifts from SLARRE to obtain the */ -/* eigenvalues of the original matrix. */ - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - itmp = iwork[iindbl + j - 1]; - w[j] += e[iwork[iinspl + itmp - 1]]; -/* L20: */ - } - } - - if (*tryrac) { -/* Refine computed eigenvalues so that they are relatively accurate */ -/* with respect to the original matrix T. */ - ibegin = 1; - wbegin = 1; - i__1 = iwork[iindbl + *m - 1]; - for (jblk = 1; jblk <= i__1; ++jblk) { - iend = iwork[iinspl + jblk - 1]; - in = iend - ibegin + 1; - wend = wbegin - 1; -/* check if any eigenvalues have to be refined in this block */ -L36: - if (wend < *m) { - if (iwork[iindbl + wend] == jblk) { - ++wend; - goto L36; - } - } - if (wend < wbegin) { - ibegin = iend + 1; - goto L39; - } - offset = iwork[iindw + wbegin - 1] - 1; - ifirst = iwork[iindw + wbegin - 1]; - ilast = iwork[iindw + wend - 1]; - rtol2 = eps * 4.f; - slarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1], - &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[ - inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], & - pivmin, &tnrm, &iinfo); - ibegin = iend + 1; - wbegin = wend + 1; -L39: - ; - } - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (scale != 1.f) { - r__1 = 1.f / scale; - sscal_(m, &r__1, &w[1], &c__1); - } - -/* If eigenvalues are not in increasing order, then sort them, */ -/* possibly along with eigenvectors. */ - - if (nsplit > 1) { - if (! wantz) { - slasrt_("I", m, &w[1], &iinfo); - if (iinfo != 0) { - *info = 3; - return 0; - } - } else { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp) { - i__ = jj; - tmp = w[jj]; - } -/* L50: */ - } - if (i__ != 0) { - w[i__] = w[j]; - w[j] = tmp; - if (wantz) { - sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * - z_dim1 + 1], &c__1); - itmp = isuppz[(i__ << 1) - 1]; - isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1]; - isuppz[(j << 1) - 1] = itmp; - itmp = isuppz[i__ * 2]; - isuppz[i__ * 2] = isuppz[j * 2]; - isuppz[j * 2] = itmp; - } - } -/* L60: */ - } - } - } - - - work[1] = (real) lwmin; - iwork[1] = liwmin; - return 0; - -/* End of SSTEMR */ - -} /* sstemr_ */ diff --git a/3rdparty/lapack/ssteqr.c b/3rdparty/lapack/ssteqr.c deleted file mode 100644 index 9f92562..0000000 --- a/3rdparty/lapack/ssteqr.c +++ /dev/null @@ -1,617 +0,0 @@ -/* ssteqr.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 real c_b9 = 0.f; -static real c_b10 = 1.f; -static integer c__0 = 0; -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int ssteqr_(char *compz, integer *n, real *d__, real *e, - real *z__, integer *ldz, real *work, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal), r_sign(real *, real *); - - /* Local variables */ - real b, c__, f, g; - integer i__, j, k, l, m; - real p, r__, s; - integer l1, ii, mm, lm1, mm1, nm1; - real rt1, rt2, eps; - integer lsv; - real tst, eps2; - integer lend, jtot; - extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *) - ; - extern logical lsame_(char *, char *); - real anorm; - extern /* Subroutine */ int slasr_(char *, char *, char *, integer *, - integer *, real *, real *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer *); - integer lendm1, lendp1; - extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real * -, real *, real *); - extern doublereal slapy2_(real *, real *); - integer iscale; - extern doublereal slamch_(char *); - real safmin; - extern /* Subroutine */ int xerbla_(char *, integer *); - real safmax; - extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, - real *, integer *, integer *, real *, integer *, integer *); - integer lendsv; - extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real * -), slaset_(char *, integer *, integer *, real *, real *, real *, - integer *); - real ssfmin; - integer nmaxit, icompz; - real ssfmax; - extern doublereal slanst_(char *, integer *, real *, real *); - extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a */ -/* symmetric tridiagonal matrix using the implicit QL or QR method. */ -/* The eigenvectors of a full or band symmetric matrix can also be found */ -/* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to */ -/* tridiagonal form. */ - -/* Arguments */ -/* ========= */ - -/* COMPZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only. */ -/* = 'V': Compute eigenvalues and eigenvectors of the original */ -/* symmetric matrix. On entry, Z must contain the */ -/* orthogonal matrix used to reduce the original matrix */ -/* to tridiagonal form. */ -/* = 'I': Compute eigenvalues and eigenvectors of the */ -/* tridiagonal matrix. Z is initialized to the identity */ -/* matrix. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) REAL array, dimension (N) */ -/* On entry, the diagonal elements of the tridiagonal matrix. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) REAL array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix. */ -/* On exit, E has been destroyed. */ - -/* Z (input/output) REAL array, dimension (LDZ, N) */ -/* On entry, if COMPZ = 'V', then Z contains the orthogonal */ -/* matrix used in the reduction to tridiagonal form. */ -/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ -/* orthonormal eigenvectors of the original symmetric matrix, */ -/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ -/* of the symmetric tridiagonal matrix. */ -/* If COMPZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* eigenvectors are desired, then LDZ >= max(1,N). */ - -/* WORK (workspace) REAL array, dimension (max(1,2*N-2)) */ -/* If COMPZ = 'N', then WORK is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: the algorithm has failed to find all the eigenvalues in */ -/* a total of 30*N iterations; if INFO = i, then i */ -/* elements of E have not converged to zero; on exit, D */ -/* and E contain the elements of a symmetric tridiagonal */ -/* matrix which is orthogonally similar to the original */ -/* matrix. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - *info = 0; - - if (lsame_(compz, "N")) { - icompz = 0; - } else if (lsame_(compz, "V")) { - icompz = 1; - } else if (lsame_(compz, "I")) { - icompz = 2; - } else { - icompz = -1; - } - if (icompz < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SSTEQR", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (icompz == 2) { - z__[z_dim1 + 1] = 1.f; - } - return 0; - } - -/* Determine the unit roundoff and over/underflow thresholds. */ - - eps = slamch_("E"); -/* Computing 2nd power */ - r__1 = eps; - eps2 = r__1 * r__1; - safmin = slamch_("S"); - safmax = 1.f / safmin; - ssfmax = sqrt(safmax) / 3.f; - ssfmin = sqrt(safmin) / eps2; - -/* Compute the eigenvalues and eigenvectors of the tridiagonal */ -/* matrix. */ - - if (icompz == 2) { - slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz); - } - - nmaxit = *n * 30; - jtot = 0; - -/* Determine where the matrix splits and choose QL or QR iteration */ -/* for each block, according to whether top or bottom diagonal */ -/* element is smaller. */ - - l1 = 1; - nm1 = *n - 1; - -L10: - if (l1 > *n) { - goto L160; - } - if (l1 > 1) { - e[l1 - 1] = 0.f; - } - if (l1 <= nm1) { - i__1 = nm1; - for (m = l1; m <= i__1; ++m) { - tst = (r__1 = e[m], dabs(r__1)); - if (tst == 0.f) { - goto L30; - } - if (tst <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m - + 1], dabs(r__2))) * eps) { - e[m] = 0.f; - goto L30; - } -/* L20: */ - } - } - m = *n; - -L30: - l = l1; - lsv = l; - lend = m; - lendsv = lend; - l1 = m + 1; - if (lend == l) { - goto L10; - } - -/* Scale submatrix in rows and columns L to LEND */ - - i__1 = lend - l + 1; - anorm = slanst_("I", &i__1, &d__[l], &e[l]); - iscale = 0; - if (anorm == 0.f) { - goto L10; - } - if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info); - } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info); - } - -/* Choose between QL and QR iteration */ - - if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) { - lend = lsv; - l = lendsv; - } - - if (lend > l) { - -/* QL Iteration */ - -/* Look for small subdiagonal element. */ - -L40: - if (l != lend) { - lendm1 = lend - 1; - i__1 = lendm1; - for (m = l; m <= i__1; ++m) { -/* Computing 2nd power */ - r__2 = (r__1 = e[m], dabs(r__1)); - tst = r__2 * r__2; - if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m - + 1], dabs(r__2)) + safmin) { - goto L60; - } -/* L50: */ - } - } - - m = lend; - -L60: - if (m < lend) { - e[m] = 0.f; - } - p = d__[l]; - if (m == l) { - goto L80; - } - -/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */ -/* to compute its eigensystem. */ - - if (m == l + 1) { - if (icompz > 0) { - slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); - work[l] = c__; - work[*n - 1 + l] = s; - slasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & - z__[l * z_dim1 + 1], ldz); - } else { - slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); - } - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.f; - l += 2; - if (l <= lend) { - goto L40; - } - goto L140; - } - - if (jtot == nmaxit) { - goto L140; - } - ++jtot; - -/* Form shift. */ - - g = (d__[l + 1] - p) / (e[l] * 2.f); - r__ = slapy2_(&g, &c_b10); - g = d__[m] - p + e[l] / (g + r_sign(&r__, &g)); - - s = 1.f; - c__ = 1.f; - p = 0.f; - -/* Inner loop */ - - mm1 = m - 1; - i__1 = l; - for (i__ = mm1; i__ >= i__1; --i__) { - f = s * e[i__]; - b = c__ * e[i__]; - slartg_(&g, &f, &c__, &s, &r__); - if (i__ != m - 1) { - e[i__ + 1] = r__; - } - g = d__[i__ + 1] - p; - r__ = (d__[i__] - g) * s + c__ * 2.f * b; - p = s * r__; - d__[i__ + 1] = g + p; - g = c__ * r__ - b; - -/* If eigenvectors are desired, then save rotations. */ - - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = -s; - } - -/* L70: */ - } - -/* If eigenvectors are desired, then apply saved rotations. */ - - if (icompz > 0) { - mm = m - l + 1; - slasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l - * z_dim1 + 1], ldz); - } - - d__[l] -= p; - e[l] = g; - goto L40; - -/* Eigenvalue found. */ - -L80: - d__[l] = p; - - ++l; - if (l <= lend) { - goto L40; - } - goto L140; - - } else { - -/* QR Iteration */ - -/* Look for small superdiagonal element. */ - -L90: - if (l != lend) { - lendp1 = lend + 1; - i__1 = lendp1; - for (m = l; m >= i__1; --m) { -/* Computing 2nd power */ - r__2 = (r__1 = e[m - 1], dabs(r__1)); - tst = r__2 * r__2; - if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m - - 1], dabs(r__2)) + safmin) { - goto L110; - } -/* L100: */ - } - } - - m = lend; - -L110: - if (m > lend) { - e[m - 1] = 0.f; - } - p = d__[l]; - if (m == l) { - goto L130; - } - -/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */ -/* to compute its eigensystem. */ - - if (m == l - 1) { - if (icompz > 0) { - slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) - ; - work[m] = c__; - work[*n - 1 + m] = s; - slasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & - z__[(l - 1) * z_dim1 + 1], ldz); - } else { - slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); - } - d__[l - 1] = rt1; - d__[l] = rt2; - e[l - 1] = 0.f; - l += -2; - if (l >= lend) { - goto L90; - } - goto L140; - } - - if (jtot == nmaxit) { - goto L140; - } - ++jtot; - -/* Form shift. */ - - g = (d__[l - 1] - p) / (e[l - 1] * 2.f); - r__ = slapy2_(&g, &c_b10); - g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g)); - - s = 1.f; - c__ = 1.f; - p = 0.f; - -/* Inner loop */ - - lm1 = l - 1; - i__1 = lm1; - for (i__ = m; i__ <= i__1; ++i__) { - f = s * e[i__]; - b = c__ * e[i__]; - slartg_(&g, &f, &c__, &s, &r__); - if (i__ != m) { - e[i__ - 1] = r__; - } - g = d__[i__] - p; - r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * b; - p = s * r__; - d__[i__] = g + p; - g = c__ * r__ - b; - -/* If eigenvectors are desired, then save rotations. */ - - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = s; - } - -/* L120: */ - } - -/* If eigenvectors are desired, then apply saved rotations. */ - - if (icompz > 0) { - mm = l - m + 1; - slasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m - * z_dim1 + 1], ldz); - } - - d__[l] -= p; - e[lm1] = g; - goto L90; - -/* Eigenvalue found. */ - -L130: - d__[l] = p; - - --l; - if (l >= lend) { - goto L90; - } - goto L140; - - } - -/* Undo scaling if necessary */ - -L140: - if (iscale == 1) { - i__1 = lendsv - lsv + 1; - slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - i__1 = lendsv - lsv; - slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, - info); - } else if (iscale == 2) { - i__1 = lendsv - lsv + 1; - slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - i__1 = lendsv - lsv; - slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, - info); - } - -/* Check for no convergence to an eigenvalue after a total */ -/* of N*MAXIT iterations. */ - - if (jtot < nmaxit) { - goto L10; - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.f) { - ++(*info); - } -/* L150: */ - } - goto L190; - -/* Order eigenvalues and eigenvectors. */ - -L160: - if (icompz == 0) { - -/* Use Quick Sort */ - - slasrt_("I", n, &d__[1], info); - - } else { - -/* Use Selection Sort to minimize swaps of eigenvectors */ - - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - k = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] < p) { - k = j; - p = d__[j]; - } -/* L170: */ - } - if (k != i__) { - d__[k] = d__[i__]; - d__[i__] = p; - sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], - &c__1); - } -/* L180: */ - } - } - -L190: - return 0; - -/* End of SSTEQR */ - -} /* ssteqr_ */ diff --git a/3rdparty/lapack/ssterf.c b/3rdparty/lapack/ssterf.c deleted file mode 100644 index 262a8c5..0000000 --- a/3rdparty/lapack/ssterf.c +++ /dev/null @@ -1,460 +0,0 @@ -/* ssterf.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__1 = 1; -static real c_b32 = 1.f; - -/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2, r__3; - - /* Builtin functions */ - double sqrt(doublereal), r_sign(real *, real *); - - /* Local variables */ - real c__; - integer i__, l, m; - real p, r__, s; - integer l1; - real bb, rt1, rt2, eps, rte; - integer lsv; - real eps2, oldc; - integer lend, jtot; - extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *) - ; - real gamma, alpha, sigma, anorm; - extern doublereal slapy2_(real *, real *); - integer iscale; - real oldgam; - extern doublereal slamch_(char *); - real safmin; - extern /* Subroutine */ int xerbla_(char *, integer *); - real safmax; - extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, - real *, integer *, integer *, real *, integer *, integer *); - integer lendsv; - real ssfmin; - integer nmaxit; - real ssfmax; - extern doublereal slanst_(char *, integer *, real *, real *); - extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix */ -/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) REAL array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) REAL array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix. */ -/* On exit, E has been destroyed. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: the algorithm failed to find all of the eigenvalues in */ -/* a total of 30*N iterations; if INFO = i, then i */ -/* elements of E have not converged to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --e; - --d__; - - /* Function Body */ - *info = 0; - -/* Quick return if possible */ - - if (*n < 0) { - *info = -1; - i__1 = -(*info); - xerbla_("SSTERF", &i__1); - return 0; - } - if (*n <= 1) { - return 0; - } - -/* Determine the unit roundoff for this environment. */ - - eps = slamch_("E"); -/* Computing 2nd power */ - r__1 = eps; - eps2 = r__1 * r__1; - safmin = slamch_("S"); - safmax = 1.f / safmin; - ssfmax = sqrt(safmax) / 3.f; - ssfmin = sqrt(safmin) / eps2; - -/* Compute the eigenvalues of the tridiagonal matrix. */ - - nmaxit = *n * 30; - sigma = 0.f; - jtot = 0; - -/* Determine where the matrix splits and choose QL or QR iteration */ -/* for each block, according to whether top or bottom diagonal */ -/* element is smaller. */ - - l1 = 1; - -L10: - if (l1 > *n) { - goto L170; - } - if (l1 > 1) { - e[l1 - 1] = 0.f; - } - i__1 = *n - 1; - for (m = l1; m <= i__1; ++m) { - if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) * - sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) { - e[m] = 0.f; - goto L30; - } -/* L20: */ - } - m = *n; - -L30: - l = l1; - lsv = l; - lend = m; - lendsv = lend; - l1 = m + 1; - if (lend == l) { - goto L10; - } - -/* Scale submatrix in rows and columns L to LEND */ - - i__1 = lend - l + 1; - anorm = slanst_("I", &i__1, &d__[l], &e[l]); - iscale = 0; - if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info); - } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info); - } - - i__1 = lend - 1; - for (i__ = l; i__ <= i__1; ++i__) { -/* Computing 2nd power */ - r__1 = e[i__]; - e[i__] = r__1 * r__1; -/* L40: */ - } - -/* Choose between QL and QR iteration */ - - if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) { - lend = lsv; - l = lendsv; - } - - if (lend >= l) { - -/* QL Iteration */ - -/* Look for small subdiagonal element. */ - -L50: - if (l != lend) { - i__1 = lend - 1; - for (m = l; m <= i__1; ++m) { - if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[ - m + 1], dabs(r__1))) { - goto L70; - } -/* L60: */ - } - } - m = lend; - -L70: - if (m < lend) { - e[m] = 0.f; - } - p = d__[l]; - if (m == l) { - goto L90; - } - -/* If remaining matrix is 2 by 2, use SLAE2 to compute its */ -/* eigenvalues. */ - - if (m == l + 1) { - rte = sqrt(e[l]); - slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.f; - l += 2; - if (l <= lend) { - goto L50; - } - goto L150; - } - - if (jtot == nmaxit) { - goto L150; - } - ++jtot; - -/* Form shift. */ - - rte = sqrt(e[l]); - sigma = (d__[l + 1] - p) / (rte * 2.f); - r__ = slapy2_(&sigma, &c_b32); - sigma = p - rte / (sigma + r_sign(&r__, &sigma)); - - c__ = 1.f; - s = 0.f; - gamma = d__[m] - sigma; - p = gamma * gamma; - -/* Inner loop */ - - i__1 = l; - for (i__ = m - 1; i__ >= i__1; --i__) { - bb = e[i__]; - r__ = p + bb; - if (i__ != m - 1) { - e[i__ + 1] = s * r__; - } - oldc = c__; - c__ = p / r__; - s = bb / r__; - oldgam = gamma; - alpha = d__[i__]; - gamma = c__ * (alpha - sigma) - s * oldgam; - d__[i__ + 1] = oldgam + (alpha - gamma); - if (c__ != 0.f) { - p = gamma * gamma / c__; - } else { - p = oldc * bb; - } -/* L80: */ - } - - e[l] = s * p; - d__[l] = sigma + gamma; - goto L50; - -/* Eigenvalue found. */ - -L90: - d__[l] = p; - - ++l; - if (l <= lend) { - goto L50; - } - goto L150; - - } else { - -/* QR Iteration */ - -/* Look for small superdiagonal element. */ - -L100: - i__1 = lend + 1; - for (m = l; m >= i__1; --m) { - if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[ - m - 1], dabs(r__1))) { - goto L120; - } -/* L110: */ - } - m = lend; - -L120: - if (m > lend) { - e[m - 1] = 0.f; - } - p = d__[l]; - if (m == l) { - goto L140; - } - -/* If remaining matrix is 2 by 2, use SLAE2 to compute its */ -/* eigenvalues. */ - - if (m == l - 1) { - rte = sqrt(e[l - 1]); - slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); - d__[l] = rt1; - d__[l - 1] = rt2; - e[l - 1] = 0.f; - l += -2; - if (l >= lend) { - goto L100; - } - goto L150; - } - - if (jtot == nmaxit) { - goto L150; - } - ++jtot; - -/* Form shift. */ - - rte = sqrt(e[l - 1]); - sigma = (d__[l - 1] - p) / (rte * 2.f); - r__ = slapy2_(&sigma, &c_b32); - sigma = p - rte / (sigma + r_sign(&r__, &sigma)); - - c__ = 1.f; - s = 0.f; - gamma = d__[m] - sigma; - p = gamma * gamma; - -/* Inner loop */ - - i__1 = l - 1; - for (i__ = m; i__ <= i__1; ++i__) { - bb = e[i__]; - r__ = p + bb; - if (i__ != m) { - e[i__ - 1] = s * r__; - } - oldc = c__; - c__ = p / r__; - s = bb / r__; - oldgam = gamma; - alpha = d__[i__ + 1]; - gamma = c__ * (alpha - sigma) - s * oldgam; - d__[i__] = oldgam + (alpha - gamma); - if (c__ != 0.f) { - p = gamma * gamma / c__; - } else { - p = oldc * bb; - } -/* L130: */ - } - - e[l - 1] = s * p; - d__[l] = sigma + gamma; - goto L100; - -/* Eigenvalue found. */ - -L140: - d__[l] = p; - - --l; - if (l >= lend) { - goto L100; - } - goto L150; - - } - -/* Undo scaling if necessary */ - -L150: - if (iscale == 1) { - i__1 = lendsv - lsv + 1; - slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - } - if (iscale == 2) { - i__1 = lendsv - lsv + 1; - slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - } - -/* Check for no convergence to an eigenvalue after a total */ -/* of N*MAXIT iterations. */ - - if (jtot < nmaxit) { - goto L10; - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.f) { - ++(*info); - } -/* L160: */ - } - goto L180; - -/* Sort eigenvalues in increasing order. */ - -L170: - slasrt_("I", n, &d__[1], info); - -L180: - return 0; - -/* End of SSTERF */ - -} /* ssterf_ */ diff --git a/3rdparty/lapack/sswap.c b/3rdparty/lapack/sswap.c deleted file mode 100644 index cb4ebfe..0000000 --- a/3rdparty/lapack/sswap.c +++ /dev/null @@ -1,114 +0,0 @@ -/* sswap.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 sswap_(integer *n, real *sx, integer *incx, real *sy, - integer *incy) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - real stemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* interchanges two vectors. */ -/* uses unrolled loops for increments equal to 1. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --sy; - --sx; - - /* 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__) { - stemp = sx[ix]; - sx[ix] = sy[iy]; - sy[iy] = stemp; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 3; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - stemp = sx[i__]; - sx[i__] = sy[i__]; - sy[i__] = stemp; -/* L30: */ - } - if (*n < 3) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 3) { - stemp = sx[i__]; - sx[i__] = sy[i__]; - sy[i__] = stemp; - stemp = sx[i__ + 1]; - sx[i__ + 1] = sy[i__ + 1]; - sy[i__ + 1] = stemp; - stemp = sx[i__ + 2]; - sx[i__ + 2] = sy[i__ + 2]; - sy[i__ + 2] = stemp; -/* L50: */ - } - return 0; -} /* sswap_ */ diff --git a/3rdparty/lapack/ssyevr.c b/3rdparty/lapack/ssyevr.c deleted file mode 100644 index 5797264..0000000 --- a/3rdparty/lapack/ssyevr.c +++ /dev/null @@ -1,658 +0,0 @@ -/* ssyevr.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__10 = 10; -static integer c__1 = 1; -static integer c__2 = 2; -static integer c__3 = 3; -static integer c__4 = 4; -static integer c_n1 = -1; - -/* Subroutine */ int ssyevr_(char *jobz, char *range, char *uplo, integer *n, - real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, - real *abstol, integer *m, real *w, real *z__, integer *ldz, integer * - isuppz, real *work, integer *lwork, integer *iwork, integer *liwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, nb, jj; - real eps, vll, vuu, tmp1; - integer indd, inde; - real anrm; - integer imax; - real rmin, rmax; - logical test; - integer inddd, indee; - real sigma; - extern logical lsame_(char *, char *); - integer iinfo; - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - char order[1]; - integer indwk, lwmin; - logical lower; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), sswap_(integer *, real *, integer *, real *, integer * -); - logical wantz, alleig, indeig; - integer iscale, ieeeok, indibl, indifl; - logical valeig; - extern doublereal slamch_(char *); - real safmin; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *); - real abstll, bignum; - integer indtau, indisp, indiwo, indwkn, liwmin; - logical tryrac; - extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *, - real *, integer *, integer *, real *, integer *, real *, integer * -, integer *, integer *), ssterf_(integer *, real *, real *, - integer *); - integer llwrkn, llwork, nsplit; - real smlnum; - extern doublereal slansy_(char *, char *, integer *, real *, integer *, - real *); - extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *, - real *, integer *, integer *, real *, real *, real *, integer *, - integer *, real *, integer *, integer *, real *, integer *, - integer *), sstemr_(char *, char *, integer *, - real *, real *, real *, real *, integer *, integer *, integer *, - real *, real *, integer *, integer *, integer *, logical *, real * -, integer *, integer *, integer *, integer *); - integer lwkopt; - logical lquery; - extern /* Subroutine */ int sormtr_(char *, char *, char *, integer *, - integer *, real *, integer *, real *, real *, integer *, real *, - integer *, integer *), ssytrd_(char *, - integer *, real *, integer *, real *, real *, real *, real *, - 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 */ -/* ======= */ - -/* SSYEVR computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ -/* selected by specifying either a range of values or a range of */ -/* indices for the desired eigenvalues. */ - -/* SSYEVR first reduces the matrix A to tridiagonal form T with a call */ -/* to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute */ -/* the eigenspectrum using Relatively Robust Representations. SSTEMR */ -/* computes eigenvalues by the dqds algorithm, while orthogonal */ -/* eigenvectors are computed from various "good" L D L^T representations */ -/* (also known as Relatively Robust Representations). Gram-Schmidt */ -/* orthogonalization is avoided as far as possible. More specifically, */ -/* the various steps of the algorithm are as follows. */ - -/* For each unreduced block (submatrix) of T, */ -/* (a) Compute T - sigma I = L D L^T, so that L and D */ -/* define all the wanted eigenvalues to high relative accuracy. */ -/* This means that small relative changes in the entries of D and L */ -/* cause only small relative changes in the eigenvalues and */ -/* eigenvectors. The standard (unfactored) representation of the */ -/* tridiagonal matrix T does not have this property in general. */ -/* (b) Compute the eigenvalues to suitable accuracy. */ -/* If the eigenvectors are desired, the algorithm attains full */ -/* accuracy of the computed eigenvalues only right before */ -/* the corresponding vectors have to be computed, see steps c) and d). */ -/* (c) For each cluster of close eigenvalues, select a new */ -/* shift close to the cluster, find a new factorization, and refine */ -/* the shifted eigenvalues to suitable accuracy. */ -/* (d) For each eigenvalue with a large enough relative separation compute */ -/* the corresponding eigenvector by forming a rank revealing twisted */ -/* factorization. Go back to (c) for any clusters that remain. */ - -/* The desired accuracy of the output can be specified by the input */ -/* parameter ABSTOL. */ - -/* For more details, see SSTEMR's documentation and: */ -/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* 2004. Also LAPACK Working Note 154. */ -/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* tridiagonal eigenvalue/eigenvector problem", */ -/* Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* UC Berkeley, May 1997. */ - - -/* Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested */ -/* on machines which conform to the ieee-754 floating point standard. */ -/* SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and */ -/* when partial spectrum requests are made. */ - -/* Normal execution of SSTEMR may create NaNs and infinities and */ -/* hence may abort due to a floating point exception in environments */ -/* which do not handle NaNs and infinities in the ieee standard default */ -/* manner. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ -/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */ -/* ********* SSTEIN are called */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA, N) */ -/* On entry, 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. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ -/* On exit, the lower triangle (if UPLO='L') or the upper */ -/* triangle (if UPLO='U') of A, including the diagonal, is */ -/* destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* VL (input) REAL */ -/* VU (input) REAL */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. 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'. */ - -/* ABSTOL (input) REAL */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing A to tridiagonal form. */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices */ -/* with Guaranteed High Relative Accuracy," by Demmel and */ -/* Kahan, LAPACK Working Note #3. */ - -/* If high relative accuracy is important, set ABSTOL to */ -/* SLAMCH( 'Safe minimum' ). Doing so will guarantee that */ -/* eigenvalues are computed to high relative accuracy when */ -/* possible in future releases. The current code does not */ -/* make any guarantees about high relative accuracy, but */ -/* future releases will. See J. Barlow and J. Demmel, */ -/* "Computing Accurate Eigensystems of Scaled Diagonally */ -/* Dominant Matrices", LAPACK Working Note #7, for a discussion */ -/* of which matrices define their eigenvalues to high relative */ -/* accuracy. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) REAL array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) REAL array, dimension (LDZ, max(1,M)) */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ -/* Supplying N columns is always safe. */ - -/* 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 ). */ -/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ - -/* WORK (workspace/output) REAL 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,26*N). */ -/* For optimal efficiency, LWORK >= (NB+6)*N, */ -/* where NB is the max of the blocksize for SSYTRD and SORMTR */ -/* returned by ILAENV. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: Internal error */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Inderjit Dhillon, IBM Almaden, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Ken Stanley, Computer Science Division, University of */ -/* California at Berkeley, USA */ -/* Jason Riedy, 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 */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - ieeeok = ilaenv_(&c__10, "SSYEVR", "N", &c__1, &c__2, &c__3, &c__4); - - lower = lsame_(uplo, "L"); - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - lquery = *lwork == -1 || *liwork == -1; - -/* Computing MAX */ - i__1 = 1, i__2 = *n * 26; - lwmin = max(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = max(i__1,i__2); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < max(1,*n)) { - *info = -6; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -8; - } - } else if (indeig) { - if (*il < 1 || *il > max(1,*n)) { - *info = -9; - } else if (*iu < min(*n,*il) || *iu > *n) { - *info = -10; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -15; - } - } - - if (*info == 0) { - nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "SORMTR", uplo, n, &c_n1, &c_n1, & - c_n1); - nb = max(i__1,i__2); -/* Computing MAX */ - i__1 = (nb + 1) * *n; - lwkopt = max(i__1,lwmin); - work[1] = (real) lwkopt; - iwork[1] = liwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -18; - } else if (*liwork < liwmin && ! lquery) { - *info = -20; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SSYEVR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - work[1] = 1.f; - return 0; - } - - if (*n == 1) { - work[1] = 26.f; - if (alleig || indeig) { - *m = 1; - w[1] = a[a_dim1 + 1]; - } else { - if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { - *m = 1; - w[1] = a[a_dim1 + 1]; - } - } - if (wantz) { - z__[z_dim1 + 1] = 1.f; - } - return 0; - } - -/* Get machine constants. */ - - safmin = slamch_("Safe minimum"); - eps = slamch_("Precision"); - smlnum = safmin / eps; - bignum = 1.f / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin)); - rmax = dmin(r__1,r__2); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - abstll = *abstol; - if (valeig) { - vll = *vl; - vuu = *vu; - } - anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]); - if (anrm > 0.f && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - if (lower) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j + 1; - sscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); -/* L10: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); -/* L20: */ - } - } - if (*abstol > 0.f) { - abstll = *abstol * sigma; - } - if (valeig) { - vll = *vl * sigma; - vuu = *vu * sigma; - } - } -/* Initialize indices into workspaces. Note: The IWORK indices are */ -/* used only if SSTERF or SSTEMR fail. */ -/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */ -/* elementary reflectors used in SSYTRD. */ - indtau = 1; -/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */ - indd = indtau + *n; -/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */ -/* tridiagonal matrix from SSYTRD. */ - inde = indd + *n; -/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */ -/* -written by SSTEMR (the SSTERF path copies the diagonal to W). */ - inddd = inde + *n; -/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */ -/* -written while computing the eigenvalues in SSTERF and SSTEMR. */ - indee = inddd + *n; -/* INDWK is the starting offset of the left-over workspace, and */ -/* LLWORK is the remaining workspace size. */ - indwk = indee + *n; - llwork = *lwork - indwk + 1; -/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and */ -/* stores the block indices of each of the M<=N eigenvalues. */ - indibl = 1; -/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and */ -/* stores the starting and finishing indices of each block. */ - indisp = indibl + *n; -/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ -/* that corresponding to eigenvectors that fail to converge in */ -/* SSTEIN. This information is discarded; if any fail, the driver */ -/* returns INFO > 0. */ - indifl = indisp + *n; -/* INDIWO is the offset of the remaining integer workspace. */ - indiwo = indisp + *n; - -/* Call SSYTRD to reduce symmetric matrix to tridiagonal form. */ - - ssytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ - indtau], &work[indwk], &llwork, &iinfo); - -/* If all eigenvalues are desired */ -/* then call SSTERF or SSTEMR and SORMTR. */ - - test = FALSE_; - if (indeig) { - if (*il == 1 && *iu == *n) { - test = TRUE_; - } - } - if ((alleig || test) && ieeeok == 1) { - if (! wantz) { - scopy_(n, &work[indd], &c__1, &w[1], &c__1); - i__1 = *n - 1; - scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - ssterf_(n, &w[1], &work[indee], info); - } else { - i__1 = *n - 1; - scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - scopy_(n, &work[indd], &c__1, &work[inddd], &c__1); - - if (*abstol <= *n * 2.f * eps) { - tryrac = TRUE_; - } else { - tryrac = FALSE_; - } - sstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu, - m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, & - work[indwk], lwork, &iwork[1], liwork, info); - - - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by SSTEIN. */ - - if (wantz && *info == 0) { - indwkn = inde; - llwrkn = *lwork - indwkn + 1; - sormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau] -, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); - } - } - - - if (*info == 0) { -/* Everything worked. Skip SSTEBZ/SSTEIN. IWORK(:) are */ -/* undefined. */ - *m = *n; - goto L30; - } - *info = 0; - } - -/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */ -/* Also call SSTEBZ and SSTEIN if SSTEMR fails. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ - inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwk], &iwork[indiwo], info); - - if (wantz) { - sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ - indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], & - iwork[indifl], info); - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by SSTEIN. */ - - indwkn = inde; - llwrkn = *lwork - indwkn + 1; - sormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ - z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - -/* Jump here if SSTEMR/SSTEIN succeeded. */ -L30: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } - r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); - } - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. */ -/* It may not be initialized (if SSTEMR/SSTEIN succeeded), and we do */ -/* not return this detailed information to the user. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L40: */ - } - - if (i__ != 0) { - w[i__] = w[j]; - w[j] = tmp1; - sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - } -/* L50: */ - } - } - -/* Set WORK(1) to optimal workspace size. */ - - work[1] = (real) lwkopt; - iwork[1] = liwmin; - - return 0; - -/* End of SSYEVR */ - -} /* ssyevr_ */ diff --git a/3rdparty/lapack/ssymv.c b/3rdparty/lapack/ssymv.c deleted file mode 100644 index 4280729..0000000 --- a/3rdparty/lapack/ssymv.c +++ /dev/null @@ -1,313 +0,0 @@ -/* ssymv.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 ssymv_(char *uplo, integer *n, real *alpha, real *a, - integer *lda, real *x, integer *incx, real *beta, real *y, integer * - incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, iy, jx, jy, kx, ky, info; - real temp1, temp2; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSYMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array A is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of A */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of A */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of A is not referenced. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of A is not referenced. */ -/* 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, n ). */ -/* Unchanged on exit. */ - -/* X - REAL array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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. */ - -/* BETA - REAL . */ -/* 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 - REAL array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the n */ -/* element 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. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*lda < max(1,*n)) { - info = 5; - } else if (*incx == 0) { - info = 7; - } else if (*incy == 0) { - info = 10; - } - if (info != 0) { - xerbla_("SSYMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0.f && *beta == 1.f) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the triangular part */ -/* of A. */ - -/* First form y := beta*y. */ - - if (*beta != 1.f) { - if (*incy == 1) { - if (*beta == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.f; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.f) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.f; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.f) { - return 0; - } - if (lsame_(uplo, "U")) { - -/* Form y when A is stored in upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.f; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[i__]; -/* L50: */ - } - y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.f; - ix = kx; - iy = ky; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; - jx += *incx; - jy += *incy; -/* L80: */ - } - } - } else { - -/* Form y when A is stored in lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.f; - y[j] += temp1 * a[j + j * a_dim1]; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[j] += *alpha * temp2; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.f; - y[jy] += temp1 * a[j + j * a_dim1]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of SSYMV . */ - -} /* ssymv_ */ diff --git a/3rdparty/lapack/ssyr2.c b/3rdparty/lapack/ssyr2.c deleted file mode 100644 index 9aea514..0000000 --- a/3rdparty/lapack/ssyr2.c +++ /dev/null @@ -1,274 +0,0 @@ -/* ssyr2.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 ssyr2_(char *uplo, integer *n, real *alpha, real *x, - integer *incx, real *y, integer *incy, real *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, iy, jx, jy, kx, ky, info; - real temp1, temp2; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSYR2 performs the symmetric rank 2 operation */ - -/* A := alpha*x*y' + alpha*y*x' + A, */ - -/* where alpha is a scalar, x and y are n element vectors and A is an n */ -/* by n symmetric matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array A is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of A */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of A */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* X - REAL array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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 - REAL 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 - REAL array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of A is not referenced. On exit, the */ -/* upper triangular part of the array A is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of A is not referenced. On exit, the */ -/* lower triangular part of the array A is overwritten by the */ -/* lower triangular part of 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, n ). */ -/* 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. */ - - /* Parameter adjustments */ - --x; - --y; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*incy == 0) { - info = 7; - } else if (*lda < max(1,*n)) { - info = 9; - } - if (info != 0) { - xerbla_("SSYR2 ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0.f) { - return 0; - } - -/* Set up the start points in X and Y if the increments are not both */ -/* unity. */ - - if (*incx != 1 || *incy != 1) { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - jx = kx; - jy = ky; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the triangular part */ -/* of A. */ - - if (lsame_(uplo, "U")) { - -/* Form A when A is stored in the upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.f || y[j] != 0.f) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * - temp1 + y[i__] * temp2; -/* L10: */ - } - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.f || y[jy] != 0.f) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = kx; - iy = ky; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * - temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L30: */ - } - } - jx += *incx; - jy += *incy; -/* L40: */ - } - } - } else { - -/* Form A when A is stored in the lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.f || y[j] != 0.f) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * - temp1 + y[i__] * temp2; -/* L50: */ - } - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.f || y[jy] != 0.f) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * - temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L70: */ - } - } - jx += *incx; - jy += *incy; -/* L80: */ - } - } - } - - return 0; - -/* End of SSYR2 . */ - -} /* ssyr2_ */ diff --git a/3rdparty/lapack/ssyr2k.c b/3rdparty/lapack/ssyr2k.c deleted file mode 100644 index 2abedb3..0000000 --- a/3rdparty/lapack/ssyr2k.c +++ /dev/null @@ -1,409 +0,0 @@ -/* ssyr2k.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 ssyr2k_(char *uplo, char *trans, integer *n, integer *k, - real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta, - real *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; - real temp1, temp2; - extern logical lsame_(char *, char *); - integer nrowa; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSYR2K performs one of the symmetric rank 2k operations */ - -/* C := alpha*A*B' + alpha*B*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*B + alpha*B'*A + beta*C, */ - -/* where alpha and beta are scalars, C is an n by n symmetric matrix */ -/* and A and B are n by k matrices in the first case and k by n */ -/* matrices in the second case. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */ -/* beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */ -/* beta*C. */ - -/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */ -/* beta*C. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrices A and B, and on entry with */ -/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ -/* of rows of the matrices A and B. K must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */ -/* k when TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array A must contain the matrix A, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* B - REAL array of DIMENSION ( LDB, kb ), where kb is */ -/* k when TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array B must contain the matrix B, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDB must be at least max( 1, n ), otherwise LDB must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - REAL . */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* C - REAL array of DIMENSION ( LDC, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array C must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of C is not referenced. On exit, the */ -/* upper triangular part of the array C is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array C must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of C is not referenced. On exit, the */ -/* lower triangular part of the array C is overwritten by the */ -/* lower triangular part of the updated matrix. */ - -/* 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, n ). */ -/* 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 .. */ -/* .. */ - -/* Test the input parameters. */ - - /* 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 */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < max(1,nrowa)) { - info = 7; - } else if (*ldb < max(1,nrowa)) { - info = 9; - } else if (*ldc < max(1,*n)) { - info = 12; - } - if (info != 0) { - xerbla_("SSYR2K", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.f) { - if (upper) { - if (*beta == 0.f) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.f) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } - -/* Start the operations. */ - - if (lsame_(trans, "N")) { - -/* Form C := alpha*A*B' + alpha*B*A' + C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.f) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L90: */ - } - } else if (*beta != 1.f) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.f || b[j + l * b_dim1] != 0.f) - { - temp1 = *alpha * b[j + l * b_dim1]; - temp2 = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ - i__ + l * a_dim1] * temp1 + b[i__ + l * - b_dim1] * temp2; -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.f) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L140: */ - } - } else if (*beta != 1.f) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.f || b[j + l * b_dim1] != 0.f) - { - temp1 = *alpha * b[j + l * b_dim1]; - temp2 = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ - i__ + l * a_dim1] * temp1 + b[i__ + l * - b_dim1] * temp2; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { - -/* Form C := alpha*A'*B + alpha*B'*A + C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1 = 0.f; - temp2 = 0.f; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; - temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; -/* L190: */ - } - if (*beta == 0.f) { - c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * - temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + *alpha * temp1 + *alpha * temp2; - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp1 = 0.f; - temp2 = 0.f; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; - temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; -/* L220: */ - } - if (*beta == 0.f) { - c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * - temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + *alpha * temp1 + *alpha * temp2; - } -/* L230: */ - } -/* L240: */ - } - } - } - - return 0; - -/* End of SSYR2K. */ - -} /* ssyr2k_ */ diff --git a/3rdparty/lapack/ssyrk.c b/3rdparty/lapack/ssyrk.c deleted file mode 100644 index 528422c..0000000 --- a/3rdparty/lapack/ssyrk.c +++ /dev/null @@ -1,372 +0,0 @@ -/* ssyrk.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 ssyrk_(char *uplo, char *trans, integer *n, integer *k, - real *alpha, real *a, integer *lda, real *beta, real *c__, integer * - ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, info; - real temp; - extern logical lsame_(char *, char *); - integer nrowa; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSYRK performs one of the symmetric rank k operations */ - -/* C := alpha*A*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*A + beta*C, */ - -/* where alpha and beta are scalars, C is an n by n symmetric matrix */ -/* and A is an n by k matrix in the first case and a k by n matrix */ -/* in the second case. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ - -/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrix A, and on entry with */ -/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ -/* of rows of the matrix A. K must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */ -/* k when TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array A must contain the matrix A, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - REAL . */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* C - REAL array of DIMENSION ( LDC, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array C must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of C is not referenced. On exit, the */ -/* upper triangular part of the array C is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array C must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of C is not referenced. On exit, the */ -/* lower triangular part of the array C is overwritten by the */ -/* lower triangular part of the updated matrix. */ - -/* 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, n ). */ -/* 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 .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < max(1,nrowa)) { - info = 7; - } else if (*ldc < max(1,*n)) { - info = 10; - } - if (info != 0) { - xerbla_("SSYRK ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.f) { - if (upper) { - if (*beta == 0.f) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.f) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } - -/* Start the operations. */ - - if (lsame_(trans, "N")) { - -/* Form C := alpha*A*A' + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.f) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L90: */ - } - } else if (*beta != 1.f) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.f) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.f) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L140: */ - } - } else if (*beta != 1.f) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.f) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { - -/* Form C := alpha*A'*A + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.f; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; -/* L190: */ - } - if (*beta == 0.f) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp = 0.f; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; -/* L220: */ - } - if (*beta == 0.f) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L230: */ - } -/* L240: */ - } - } - } - - return 0; - -/* End of SSYRK . */ - -} /* ssyrk_ */ diff --git a/3rdparty/lapack/ssytd2.c b/3rdparty/lapack/ssytd2.c deleted file mode 100644 index f7bb3c1..0000000 --- a/3rdparty/lapack/ssytd2.c +++ /dev/null @@ -1,302 +0,0 @@ -/* ssytd2.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 real c_b8 = 0.f; -static real c_b14 = -1.f; - -/* Subroutine */ int ssytd2_(char *uplo, integer *n, real *a, integer *lda, - real *d__, real *e, real *tau, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - real taui; - extern doublereal sdot_(integer *, real *, integer *, real *, integer *); - extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *, - integer *, real *, integer *, real *, integer *); - real alpha; - extern logical lsame_(char *, char *); - logical upper; - extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, - real *, integer *), ssymv_(char *, integer *, real *, real *, - integer *, real *, integer *, real *, real *, integer *), - xerbla_(char *, integer *), slarfg_(integer *, real *, - real *, integer *, real *); - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */ -/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ -/* of A are overwritten by the corresponding elements of the */ -/* tridiagonal matrix T, and the elements above the first */ -/* superdiagonal, with the array TAU, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors; if UPLO */ -/* = 'L', the diagonal and first subdiagonal of A are over- */ -/* written by the corresponding elements of the tridiagonal */ -/* matrix T, and the elements below the first subdiagonal, 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,N). */ - -/* D (output) REAL array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T: */ -/* D(i) = A(i,i). */ - -/* E (output) REAL array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix T: */ -/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ - -/* TAU (output) REAL array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n-1) . . . H(2) H(1). */ - -/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ -/* A(1:i-1,i+1), and tau in TAU(i). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(n-1). */ - -/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ -/* and tau in TAU(i). */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( d e v2 v3 v4 ) ( d ) */ -/* ( d e v3 v4 ) ( e d ) */ -/* ( d e v4 ) ( v1 e d ) */ -/* ( d e ) ( v1 v2 e d ) */ -/* ( d ) ( v1 v2 v3 e d ) */ - -/* where d and e denote diagonal and off-diagonal elements of T, and vi */ -/* denotes an element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. 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; - --d__; - --e; - --tau; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SSYTD2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - - if (upper) { - -/* Reduce the upper triangle of A */ - - for (i__ = *n - 1; i__ >= 1; --i__) { - -/* Generate elementary reflector H(i) = I - tau * v * v' */ -/* to annihilate A(1:i-1,i+1) */ - - slarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 - + 1], &c__1, &taui); - e[i__] = a[i__ + (i__ + 1) * a_dim1]; - - if (taui != 0.f) { - -/* Apply H(i) from both sides to A(1:i,1:i) */ - - a[i__ + (i__ + 1) * a_dim1] = 1.f; - -/* Compute x := tau * A * v storing x in TAU(1:i) */ - - ssymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * - a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1); - -/* Compute w := x - 1/2 * tau * (x'*v) * v */ - - alpha = taui * -.5f * sdot_(&i__, &tau[1], &c__1, &a[(i__ + 1) - * a_dim1 + 1], &c__1); - saxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ - 1], &c__1); - -/* Apply the transformation as a rank-2 update: */ -/* A := A - v * w' - w * v' */ - - ssyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, - &tau[1], &c__1, &a[a_offset], lda); - - a[i__ + (i__ + 1) * a_dim1] = e[i__]; - } - d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1]; - tau[i__] = taui; -/* L10: */ - } - d__[1] = a[a_dim1 + 1]; - } else { - -/* Reduce the lower triangle of A */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) = I - tau * v * v' */ -/* to annihilate A(i+2:n,i) */ - - i__2 = *n - i__; -/* Computing MIN */ - i__3 = i__ + 2; - slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ * - a_dim1], &c__1, &taui); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - - if (taui != 0.f) { - -/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ - - a[i__ + 1 + i__ * a_dim1] = 1.f; - -/* Compute x := tau * A * v storing y in TAU(i:n-1) */ - - i__2 = *n - i__; - ssymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ - i__], &c__1); - -/* Compute w := x - 1/2 * tau * (x'*v) * v */ - - i__2 = *n - i__; - alpha = taui * -.5f * sdot_(&i__2, &tau[i__], &c__1, &a[i__ + - 1 + i__ * a_dim1], &c__1); - i__2 = *n - i__; - saxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ - i__], &c__1); - -/* Apply the transformation as a rank-2 update: */ -/* A := A - v * w' - w * v' */ - - i__2 = *n - i__; - ssyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, - &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda); - - a[i__ + 1 + i__ * a_dim1] = e[i__]; - } - d__[i__] = a[i__ + i__ * a_dim1]; - tau[i__] = taui; -/* L20: */ - } - d__[*n] = a[*n + *n * a_dim1]; - } - - return 0; - -/* End of SSYTD2 */ - -} /* ssytd2_ */ diff --git a/3rdparty/lapack/ssytrd.c b/3rdparty/lapack/ssytrd.c deleted file mode 100644 index 726c5b3..0000000 --- a/3rdparty/lapack/ssytrd.c +++ /dev/null @@ -1,360 +0,0 @@ -/* ssytrd.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 real c_b22 = -1.f; -static real c_b23 = 1.f; - -/* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda, - real *d__, real *e, real *tau, real *work, integer *lwork, integer * - info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, nb, kk, nx, iws; - extern logical lsame_(char *, char *); - integer nbmin, iinfo; - logical upper; - extern /* Subroutine */ int ssytd2_(char *, integer *, real *, integer *, - real *, real *, real *, integer *), ssyr2k_(char *, char * -, integer *, integer *, real *, real *, integer *, real *, - integer *, real *, real *, integer *), xerbla_( - char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - extern /* Subroutine */ int slatrd_(char *, integer *, integer *, real *, - integer *, real *, real *, real *, 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 */ -/* ======= */ - -/* SSYTRD reduces a real symmetric matrix A to real symmetric */ -/* tridiagonal form T by an orthogonal similarity transformation: */ -/* Q**T * A * Q = T. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ -/* of A are overwritten by the corresponding elements of the */ -/* tridiagonal matrix T, and the elements above the first */ -/* superdiagonal, with the array TAU, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors; if UPLO */ -/* = 'L', the diagonal and first subdiagonal of A are over- */ -/* written by the corresponding elements of the tridiagonal */ -/* matrix T, and the elements below the first subdiagonal, 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,N). */ - -/* D (output) REAL array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T: */ -/* D(i) = A(i,i). */ - -/* E (output) REAL array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix T: */ -/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ - -/* TAU (output) REAL array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* WORK (workspace/output) REAL 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 >= 1. */ -/* 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 */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n-1) . . . H(2) H(1). */ - -/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ -/* A(1:i-1,i+1), and tau in TAU(i). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(n-1). */ - -/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ -/* and tau in TAU(i). */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( d e v2 v3 v4 ) ( d ) */ -/* ( d e v3 v4 ) ( e d ) */ -/* ( d e v4 ) ( v1 e d ) */ -/* ( d e ) ( v1 v2 e d ) */ -/* ( d ) ( v1 v2 v3 e d ) */ - -/* where d and e denote diagonal and off-diagonal elements of T, and vi */ -/* denotes an element of the vector defining H(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; - --tau; - --work; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } else if (*lwork < 1 && ! lquery) { - *info = -9; - } - - if (*info == 0) { - -/* Determine the block size. */ - - nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (real) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("SSYTRD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - work[1] = 1.f; - return 0; - } - - nx = *n; - iws = 1; - if (nb > 1 && nb < *n) { - -/* Determine when to cross over from blocked to unblocked code */ -/* (last block is always handled by unblocked code). */ - -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, "SSYTRD", uplo, n, &c_n1, &c_n1, & - c_n1); - nx = max(i__1,i__2); - if (nx < *n) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: determine the */ -/* minimum value of NB, and reduce NB or force use of */ -/* unblocked code by setting NX = N. */ - -/* Computing MAX */ - i__1 = *lwork / ldwork; - nb = max(i__1,1); - nbmin = ilaenv_(&c__2, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); - if (nb < nbmin) { - nx = *n; - } - } - } else { - nx = *n; - } - } else { - nb = 1; - } - - if (upper) { - -/* Reduce the upper triangle of A. */ -/* Columns 1:kk are handled by the unblocked method. */ - - kk = *n - (*n - nx + nb - 1) / nb * nb; - i__1 = kk + 1; - i__2 = -nb; - for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { - -/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ -/* matrix W which is needed to update the unreduced part of */ -/* the matrix */ - - i__3 = i__ + nb - 1; - slatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & - work[1], &ldwork); - -/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ -/* update of the form: A := A - V*W' - W*V' */ - - i__3 = i__ - 1; - ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 - + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda); - -/* Copy superdiagonal elements back into A, and diagonal */ -/* elements into D */ - - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j - 1 + j * a_dim1] = e[j - 1]; - d__[j] = a[j + j * a_dim1]; -/* L10: */ - } -/* L20: */ - } - -/* Use unblocked code to reduce the last or only block */ - - ssytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo); - } else { - -/* Reduce the lower triangle of A */ - - i__2 = *n - nx; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { - -/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ -/* matrix W which is needed to update the unreduced part of */ -/* the matrix */ - - i__3 = *n - i__ + 1; - slatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & - tau[i__], &work[1], &ldwork); - -/* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */ -/* an update of the form: A := A - V*W' - W*V' */ - - i__3 = *n - i__ - nb + 1; - ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + - i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ - i__ + nb + (i__ + nb) * a_dim1], lda); - -/* Copy subdiagonal elements back into A, and diagonal */ -/* elements into D */ - - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j + 1 + j * a_dim1] = e[j]; - d__[j] = a[j + j * a_dim1]; -/* L30: */ - } -/* L40: */ - } - -/* Use unblocked code to reduce the last or only block */ - - i__1 = *n - i__ + 1; - ssytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], - &tau[i__], &iinfo); - } - - work[1] = (real) lwkopt; - return 0; - -/* End of SSYTRD */ - -} /* ssytrd_ */ diff --git a/3rdparty/lapack/strmm.c b/3rdparty/lapack/strmm.c deleted file mode 100644 index bf83224..0000000 --- a/3rdparty/lapack/strmm.c +++ /dev/null @@ -1,453 +0,0 @@ -/* strmm.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 strmm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, real *alpha, real *a, integer *lda, real *b, - integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, info; - real temp; - logical lside; - extern logical lsame_(char *, char *); - integer nrowa; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - logical nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* STRMM performs one of the matrix-matrix operations */ - -/* B := alpha*op( A )*B, or B := alpha*B*op( A ), */ - -/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */ -/* non-unit, upper or lower triangular matrix and op( A ) is one of */ - -/* op( A ) = A or op( A ) = A'. */ - -/* Arguments */ -/* ========== */ - -/* SIDE - CHARACTER*1. */ -/* On entry, SIDE specifies whether op( A ) multiplies B from */ -/* the left or right as follows: */ - -/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */ - -/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */ - -/* Unchanged on exit. */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix A is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* 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. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit triangular */ -/* as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* M - INTEGER. */ -/* On entry, M specifies the number of rows of B. M must be at */ -/* least zero. */ -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the number of columns of B. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. When alpha is */ -/* zero then A is not referenced and B need not be set before */ -/* entry. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, k ), where k is m */ -/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ -/* Before entry with UPLO = 'U' or 'u', the leading k by k */ -/* upper triangular part of the array A must contain the upper */ -/* triangular matrix and the strictly lower triangular part of */ -/* A is not referenced. */ -/* Before entry with UPLO = 'L' or 'l', the leading k by k */ -/* lower triangular part of the array A must contain the lower */ -/* triangular matrix and the strictly upper triangular part of */ -/* A is not referenced. */ -/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ -/* A are not referenced either, but are assumed to be unity. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ -/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ -/* then LDA must be at least max( 1, n ). */ -/* Unchanged on exit. */ - -/* B - REAL array of DIMENSION ( LDB, n ). */ -/* Before entry, the leading m by n part of the array B must */ -/* contain the matrix B, and on exit is overwritten by the */ -/* transformed matrix. */ - -/* LDB - INTEGER. */ -/* On entry, LDB specifies the first dimension of B as declared */ -/* in the calling (sub) program. LDB 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 .. */ -/* .. */ - -/* Test the input parameters. */ - - /* 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 */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < max(1,nrowa)) { - info = 9; - } else if (*ldb < max(1,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("STRMM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.f) { - 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] = 0.f; -/* L10: */ - } -/* L20: */ - } - return 0; - } - -/* Start the operations. */ - - if (lside) { - if (lsame_(transa, "N")) { - -/* Form B := alpha*A*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.f) { - temp = *alpha * b[k + j * b_dim1]; - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * a[i__ + k * - a_dim1]; -/* L30: */ - } - if (nounit) { - temp *= a[k + k * a_dim1]; - } - b[k + j * b_dim1] = temp; - } -/* L40: */ - } -/* L50: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.f) { - temp = *alpha * b[k + j * b_dim1]; - b[k + j * b_dim1] = temp; - if (nounit) { - b[k + j * b_dim1] *= a[k + k * a_dim1]; - } - i__2 = *m; - for (i__ = k + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * a[i__ + k * - a_dim1]; -/* L60: */ - } - } -/* L70: */ - } -/* L80: */ - } - } - } else { - -/* Form B := alpha*A'*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = b[i__ + j * b_dim1]; - if (nounit) { - temp *= a[i__ + i__ * a_dim1]; - } - i__2 = i__ - 1; - for (k = 1; k <= i__2; ++k) { - temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L90: */ - } - b[i__ + j * b_dim1] = *alpha * temp; -/* L100: */ - } -/* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = b[i__ + j * b_dim1]; - if (nounit) { - temp *= a[i__ + i__ * a_dim1]; - } - i__3 = *m; - for (k = i__ + 1; k <= i__3; ++k) { - temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L120: */ - } - b[i__ + j * b_dim1] = *alpha * temp; -/* L130: */ - } -/* L140: */ - } - } - } - } else { - if (lsame_(transa, "N")) { - -/* Form B := alpha*B*A. */ - - if (upper) { - for (j = *n; j >= 1; --j) { - temp = *alpha; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L150: */ - } - i__1 = j - 1; - for (k = 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.f) { - temp = *alpha * a[k + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = *alpha; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L190: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.f) { - temp = *alpha * a[k + j * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L200: */ - } - } -/* L210: */ - } -/* L220: */ - } - } - } else { - -/* Form B := alpha*B*A'. */ - - if (upper) { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - i__2 = k - 1; - for (j = 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.f) { - temp = *alpha * a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L230: */ - } - } -/* L240: */ - } - temp = *alpha; - if (nounit) { - temp *= a[k + k * a_dim1]; - } - if (temp != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L250: */ - } - } -/* L260: */ - } - } else { - for (k = *n; k >= 1; --k) { - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.f) { - temp = *alpha * a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L270: */ - } - } -/* L280: */ - } - temp = *alpha; - if (nounit) { - temp *= a[k + k * a_dim1]; - } - if (temp != 1.f) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L290: */ - } - } -/* L300: */ - } - } - } - } - - return 0; - -/* End of STRMM . */ - -} /* strmm_ */ diff --git a/3rdparty/lapack/strmv.c b/3rdparty/lapack/strmv.c deleted file mode 100644 index b3cf7f0..0000000 --- a/3rdparty/lapack/strmv.c +++ /dev/null @@ -1,345 +0,0 @@ -/* strmv.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 strmv_(char *uplo, char *trans, char *diag, integer *n, - real *a, integer *lda, real *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, jx, kx, info; - real temp; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int xerbla_(char *, integer *); - logical nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* STRMV performs one of the matrix-vector operations */ - -/* x := A*x, or x := A'*x, */ - -/* where x is an n element vector and A is an n by n unit, or non-unit, */ -/* upper or lower triangular matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' x := A*x. */ - -/* TRANS = 'T' or 't' x := A'*x. */ - -/* TRANS = 'C' or 'c' x := A'*x. */ - -/* Unchanged on exit. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit */ -/* triangular as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular matrix and the strictly lower triangular part of */ -/* A is not referenced. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular matrix and the strictly upper triangular part of */ -/* A is not referenced. */ -/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ -/* A are not referenced either, but are assumed to be unity. */ -/* 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, n ). */ -/* Unchanged on exit. */ - -/* X - REAL array of dimension at least */ -/* ( 1 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* element vector x. On exit, X is overwritten with the */ -/* tranformed vector x. */ - -/* INCX - INTEGER. */ -/* On entry, INCX specifies the increment for the elements of */ -/* X. INCX 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. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*lda < max(1,*n)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } - if (info != 0) { - xerbla_("STRMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - nounit = lsame_(diag, "N"); - -/* Set up the start point in X if the increment is not unity. This */ -/* will be ( N - 1 )*INCX too small for descending loops. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N")) { - -/* Form x := A*x. */ - - if (lsame_(uplo, "U")) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.f) { - temp = x[j]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__] += temp * a[i__ + j * a_dim1]; -/* L10: */ - } - if (nounit) { - x[j] *= a[j + j * a_dim1]; - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.f) { - temp = x[jx]; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[ix] += temp * a[i__ + j * a_dim1]; - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= a[j + j * a_dim1]; - } - } - jx += *incx; -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.f) { - temp = x[j]; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[i__] += temp * a[i__ + j * a_dim1]; -/* L50: */ - } - if (nounit) { - x[j] *= a[j + j * a_dim1]; - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.f) { - temp = x[jx]; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[ix] += temp * a[i__ + j * a_dim1]; - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= a[j + j * a_dim1]; - } - } - jx -= *incx; -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x. */ - - if (lsame_(uplo, "U")) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - for (i__ = j - 1; i__ >= 1; --i__) { - temp += a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - x[j] = temp; -/* L100: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - temp += a[i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[i__]; -/* L130: */ - } - x[j] = temp; -/* L140: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - temp += a[i__ + j * a_dim1] * x[ix]; -/* L150: */ - } - x[jx] = temp; - jx += *incx; -/* L160: */ - } - } - } - } - - return 0; - -/* End of STRMV . */ - -} /* strmv_ */ diff --git a/3rdparty/lapack/strsm.c b/3rdparty/lapack/strsm.c deleted file mode 100644 index 8a6ff18..0000000 --- a/3rdparty/lapack/strsm.c +++ /dev/null @@ -1,490 +0,0 @@ -/* strsm.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 strsm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, real *alpha, real *a, integer *lda, real *b, - integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, info; - real temp; - logical lside; - extern logical lsame_(char *, char *); - integer nrowa; - logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - logical nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* STRSM solves one of the matrix equations */ - -/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ - -/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ -/* non-unit, upper or lower triangular matrix and op( A ) is one of */ - -/* op( A ) = A or op( A ) = A'. */ - -/* The matrix X is overwritten on B. */ - -/* Arguments */ -/* ========== */ - -/* SIDE - CHARACTER*1. */ -/* On entry, SIDE specifies whether op( A ) appears on the left */ -/* or right of X as follows: */ - -/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ - -/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ - -/* Unchanged on exit. */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the matrix A is an upper or */ -/* lower triangular matrix as follows: */ - -/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ - -/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ - -/* Unchanged on exit. */ - -/* 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. */ - -/* DIAG - CHARACTER*1. */ -/* On entry, DIAG specifies whether or not A is unit triangular */ -/* as follows: */ - -/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ - -/* DIAG = 'N' or 'n' A is not assumed to be unit */ -/* triangular. */ - -/* Unchanged on exit. */ - -/* M - INTEGER. */ -/* On entry, M specifies the number of rows of B. M must be at */ -/* least zero. */ -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the number of columns of B. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. When alpha is */ -/* zero then A is not referenced and B need not be set before */ -/* entry. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, k ), where k is m */ -/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ -/* Before entry with UPLO = 'U' or 'u', the leading k by k */ -/* upper triangular part of the array A must contain the upper */ -/* triangular matrix and the strictly lower triangular part of */ -/* A is not referenced. */ -/* Before entry with UPLO = 'L' or 'l', the leading k by k */ -/* lower triangular part of the array A must contain the lower */ -/* triangular matrix and the strictly upper triangular part of */ -/* A is not referenced. */ -/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ -/* A are not referenced either, but are assumed to be unity. */ -/* Unchanged on exit. */ - -/* LDA - INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ -/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ -/* then LDA must be at least max( 1, n ). */ -/* Unchanged on exit. */ - -/* B - REAL array of DIMENSION ( LDB, n ). */ -/* Before entry, the leading m by n part of the array B must */ -/* contain the right-hand side matrix B, and on exit is */ -/* overwritten by the solution matrix X. */ - -/* LDB - INTEGER. */ -/* On entry, LDB specifies the first dimension of B as declared */ -/* in the calling (sub) program. LDB 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 .. */ -/* .. */ - -/* Test the input parameters. */ - - /* 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 */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < max(1,nrowa)) { - info = 9; - } else if (*ldb < max(1,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("STRSM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.f) { - 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] = 0.f; -/* L10: */ - } -/* L20: */ - } - return 0; - } - -/* Start the operations. */ - - if (lside) { - if (lsame_(transa, "N")) { - -/* Form B := alpha*inv( A )*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L30: */ - } - } - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.f) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__2 = k - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; -/* L40: */ - } - } -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L70: */ - } - } - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.f) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__3 = *m; - for (i__ = k + 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; -/* L80: */ - } - } -/* L90: */ - } -/* L100: */ - } - } - } else { - -/* Form B := alpha*inv( A' )*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L110: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L140: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; -/* L150: */ - } -/* L160: */ - } - } - } - } else { - if (lsame_(transa, "N")) { - -/* Form B := alpha*B*inv( A ). */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L170: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.f) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; -/* L180: */ - } - } -/* L190: */ - } - if (nounit) { - temp = 1.f / a[j + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L200: */ - } - } -/* L210: */ - } - } else { - for (j = *n; j >= 1; --j) { - if (*alpha != 1.f) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L220: */ - } - } - i__1 = *n; - for (k = j + 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; -/* L230: */ - } - } -/* L240: */ - } - if (nounit) { - temp = 1.f / a[j + j * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L250: */ - } - } -/* L260: */ - } - } - } else { - -/* Form B := alpha*B*inv( A' ). */ - - if (upper) { - for (k = *n; k >= 1; --k) { - if (nounit) { - temp = 1.f / a[k + k * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L270: */ - } - } - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.f) { - temp = a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; -/* L280: */ - } - } -/* L290: */ - } - if (*alpha != 1.f) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; -/* L300: */ - } - } -/* L310: */ - } - } else { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (nounit) { - temp = 1.f / a[k + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L320: */ - } - } - i__2 = *n; - for (j = k + 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.f) { - temp = a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; -/* L330: */ - } - } -/* L340: */ - } - if (*alpha != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; -/* L350: */ - } - } -/* L360: */ - } - } - } - } - - return 0; - -/* End of STRSM . */ - -} /* strsm_ */ diff --git a/3rdparty/lapack/strti2.c b/3rdparty/lapack/strti2.c deleted file mode 100644 index 25f0a3e..0000000 --- a/3rdparty/lapack/strti2.c +++ /dev/null @@ -1,183 +0,0 @@ -/* strti2.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 strti2_(char *uplo, char *diag, integer *n, real *a, - integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer j; - real ajj; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - logical upper; - extern /* Subroutine */ int strmv_(char *, char *, char *, integer *, - real *, integer *, real *, integer *), - xerbla_(char *, integer *); - logical nounit; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* STRTI2 computes the inverse of a real upper or lower triangular */ -/* matrix. */ - -/* This is the Level 2 BLAS version of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the triangular matrix A. If UPLO = 'U', the */ -/* leading n by n upper triangular part of the array A contains */ -/* the upper triangular matrix, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of the array A contains */ -/* the lower triangular matrix, and the strictly upper */ -/* triangular part of A is not referenced. If DIAG = 'U', the */ -/* diagonal elements of A are also not referenced and are */ -/* assumed to be 1. */ - -/* On exit, the (triangular) inverse of the original matrix, in */ -/* the same storage format. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("STRTI2", &i__1); - return 0; - } - - if (upper) { - -/* Compute inverse of upper triangular matrix. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (nounit) { - a[j + j * a_dim1] = 1.f / a[j + j * a_dim1]; - ajj = -a[j + j * a_dim1]; - } else { - ajj = -1.f; - } - -/* Compute elements 1:j-1 of j-th column. */ - - i__2 = j - 1; - strmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, & - a[j * a_dim1 + 1], &c__1); - i__2 = j - 1; - sscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); -/* L10: */ - } - } else { - -/* Compute inverse of lower triangular matrix. */ - - for (j = *n; j >= 1; --j) { - if (nounit) { - a[j + j * a_dim1] = 1.f / a[j + j * a_dim1]; - ajj = -a[j + j * a_dim1]; - } else { - ajj = -1.f; - } - if (j < *n) { - -/* Compute elements j+1:n of j-th column. */ - - i__1 = *n - j; - strmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j + - 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1); - i__1 = *n - j; - sscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); - } -/* L20: */ - } - } - - return 0; - -/* End of STRTI2 */ - -} /* strti2_ */ diff --git a/3rdparty/lapack/strtri.c b/3rdparty/lapack/strtri.c deleted file mode 100644 index 4737472..0000000 --- a/3rdparty/lapack/strtri.c +++ /dev/null @@ -1,241 +0,0 @@ -/* strtri.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 real c_b18 = 1.f; -static real c_b22 = -1.f; - -/* Subroutine */ int strtri_(char *uplo, char *diag, integer *n, real *a, - integer *lda, integer *info) -{ - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5; - char ch__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer j, jb, nb, nn; - extern logical lsame_(char *, char *); - logical upper; - extern /* Subroutine */ int strmm_(char *, char *, char *, char *, - integer *, integer *, real *, real *, integer *, real *, integer * -), strsm_(char *, char *, char *, - char *, integer *, integer *, real *, real *, integer *, real *, - integer *), strti2_(char *, char * -, integer *, real *, integer *, integer *), - xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *); - logical nounit; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* STRTRI computes the inverse of a real upper or lower triangular */ -/* matrix A. */ - -/* This is the Level 3 BLAS version of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the triangular matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of the array A contains */ -/* the upper triangular matrix, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of the array A contains */ -/* the lower triangular matrix, and the strictly upper */ -/* triangular part of A is not referenced. If DIAG = 'U', the */ -/* diagonal elements of A are also not referenced and are */ -/* assumed to be 1. */ -/* On exit, the (triangular) inverse of the original matrix, in */ -/* the same storage format. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= 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, A(i,i) is exactly zero. The triangular */ -/* matrix is singular and its inverse can 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; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("STRTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity if non-unit. */ - - if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a[*info + *info * a_dim1] == 0.f) { - return 0; - } -/* L10: */ - } - *info = 0; - } - -/* Determine the block size for this environment. */ - -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = uplo; - i__2[1] = 1, a__1[1] = diag; - s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); - nb = ilaenv_(&c__1, "STRTRI", ch__1, n, &c_n1, &c_n1, &c_n1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - strti2_(uplo, diag, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute inverse of upper triangular matrix */ - - i__1 = *n; - i__3 = nb; - for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { -/* Computing MIN */ - i__4 = nb, i__5 = *n - j + 1; - jb = min(i__4,i__5); - -/* Compute rows 1:j-1 of current block column */ - - i__4 = j - 1; - strmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, & - c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda); - i__4 = j - 1; - strsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, & - c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], - lda); - -/* Compute inverse of current diagonal block */ - - strti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info); -/* L20: */ - } - } else { - -/* Compute inverse of lower triangular matrix */ - - nn = (*n - 1) / nb * nb + 1; - i__3 = -nb; - for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { -/* Computing MIN */ - i__1 = nb, i__4 = *n - j + 1; - jb = min(i__1,i__4); - if (j + jb <= *n) { - -/* Compute rows j+jb:n of current block column */ - - i__1 = *n - j - jb + 1; - strmm_("Left", "Lower", "No transpose", diag, &i__1, &jb, - &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j - + jb + j * a_dim1], lda); - i__1 = *n - j - jb + 1; - strsm_("Right", "Lower", "No transpose", diag, &i__1, &jb, - &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j * - a_dim1], lda); - } - -/* Compute inverse of current diagonal block */ - - strti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info); -/* L30: */ - } - } - } - - return 0; - -/* End of STRTRI */ - -} /* strtri_ */ diff --git a/3rdparty/lapack/strtrs.c b/3rdparty/lapack/strtrs.c deleted file mode 100644 index b4660eb..0000000 --- a/3rdparty/lapack/strtrs.c +++ /dev/null @@ -1,182 +0,0 @@ -/* strtrs.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 real c_b12 = 1.f; - -/* Subroutine */ int strtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *a, integer *lda, real *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 strsm_(char *, char *, char *, char *, - integer *, integer *, real *, real *, integer *, real *, integer * -), xerbla_(char *, integer *); - logical nounit; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* STRTRS solves a triangular system of the form */ - -/* A * X = B or A**T * X = B, */ - -/* where A is a triangular matrix of order N, and B is an N-by-NRHS */ -/* matrix. A check is made to verify that A is nonsingular. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* 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) REAL array, dimension (LDA,N) */ -/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) REAL array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, if INFO = 0, 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 */ -/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ -/* indicating that the matrix is singular and the solutions */ -/* X have not been 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; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - nounit = lsame_(diag, "N"); - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*lda < max(1,*n)) { - *info = -7; - } else if (*ldb < max(1,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("STRTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity. */ - - if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a[*info + *info * a_dim1] == 0.f) { - return 0; - } -/* L10: */ - } - } - *info = 0; - -/* Solve A * x = b or A' * x = b. */ - - strsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[ - b_offset], ldb); - - return 0; - -/* End of STRTRS */ - -} /* strtrs_ */ diff --git a/3rdparty/lapack/xerbla.c b/3rdparty/lapack/xerbla.c deleted file mode 100644 index 01687e1..0000000 --- a/3rdparty/lapack/xerbla.c +++ /dev/null @@ -1,76 +0,0 @@ -/* xerbla.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 xerbla_(char *srname, integer *info) -{ - /* Format strings */ - static char fmt_9999[] = "(\002 ** On entry to \002,a,\002 parameter num" - "ber \002,i2,\002 had \002,\002an illegal value\002)"; - - /* Builtin functions */ - integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *, - char *, ftnlen), e_wsfe(void); - /* Subroutine */ int s_stop(char *, ftnlen); - - /* Fortran I/O blocks */ - static cilist io___1 = { 0, 6, 0, fmt_9999, 0 }; - - - -/* -- LAPACK auxiliary routine (preliminary version) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* XERBLA is an error handler for the LAPACK routines. */ -/* It is called by an LAPACK routine if an input parameter has an */ -/* invalid value. A message is printed and execution stops. */ - -/* Installers may consider modifying the STOP statement in order to */ -/* call system-specific exception-handling facilities. */ - -/* Arguments */ -/* ========= */ - -/* SRNAME (input) CHARACTER*(*) */ -/* The name of the routine which called XERBLA. */ - -/* INFO (input) INTEGER */ -/* The position of the invalid parameter in the parameter list */ -/* of the calling routine. */ - -/* ===================================================================== */ - -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - printf("** On entry to %6s, parameter number %2i had an illegal value\n", - srname, *info); - - -/* End of XERBLA */ - - return 0; -} /* xerbla_ */ diff --git a/3rdparty/readme.txt b/3rdparty/readme.txt index 768efd3..b06f83d 100644 --- a/3rdparty/readme.txt +++ b/3rdparty/readme.txt @@ -104,14 +104,3 @@ videoInput-0.1995 - Video capturing library for Windows using DirectShow as back http://muonics.net/school/spring05/videoInput/ ------------------------------------------------------------------------------------ - -clapack-3.2.1 - F2C translation of the Linear Algebra PACKage (LAPACK), - Copyright (c) 1992-2010 The University of Tennessee. All rights reserved. - http://www.netlib.org/lapack/ - http://www.netlib.org/clapack/ - - Note, that only a subset of package is used in OpenCV. - It can be extended and/or replaced with future upstream releases - in the future. - ------------------------------------------------------------------------------------- diff --git a/OpenCVConfig.cmake.in b/OpenCVConfig.cmake.in index efe3593..7d64895 100644 --- a/OpenCVConfig.cmake.in +++ b/OpenCVConfig.cmake.in @@ -52,42 +52,42 @@ LINK_DIRECTORIES(${OpenCV_LIB_DIR}) # ==================================================================== # Link libraries: e.g. opencv_core220.so, opencv_imgproc220d.lib, etc... -# ==================================================================== +# ==================================================================== if(NOT ANDROID) - set(OPENCV_LIB_COMPONENTS opencv_core opencv_imgproc opencv_features2d opencv_gpu opencv_calib3d opencv_objdetect opencv_video opencv_highgui opencv_ml opencv_legacy opencv_contrib opencv_flann) -else() - #libraries order is very important because linker from Android NDK is one-pass linker - set(OPENCV_LIB_COMPONENTS opencv_calib3d opencv_objdetect opencv_features2d opencv_imgproc opencv_video opencv_highgui opencv_ml opencv_legacy opencv_flann opencv_core ) -endif() + set(OPENCV_LIB_COMPONENTS opencv_core opencv_imgproc opencv_features2d opencv_gpu opencv_calib3d opencv_objdetect opencv_video opencv_highgui opencv_ml opencv_legacy opencv_contrib opencv_flann) +else() + #libraries order is very important because linker from Android NDK is one-pass linker + set(OPENCV_LIB_COMPONENTS opencv_calib3d opencv_objdetect opencv_features2d opencv_imgproc opencv_video opencv_highgui opencv_ml opencv_legacy opencv_flann opencv_core ) +endif() SET(OpenCV_LIBS "") foreach(__CVLIB ${OPENCV_LIB_COMPONENTS}) - # CMake>=2.6 supports the notation "debug XXd optimized XX" - if (CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4) - # Modern CMake: - SET(OpenCV_LIBS ${OpenCV_LIBS} debug ${__CVLIB}@OPENCV_DLLVERSION@@OPENCV_DEBUG_POSTFIX@ optimized ${__CVLIB}@OPENCV_DLLVERSION@) - else(CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4) - # Old CMake: - SET(OpenCV_LIBS ${OpenCV_LIBS} ${__CVLIB}@OPENCV_DLLVERSION@) - endif(CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4) + # CMake>=2.6 supports the notation "debug XXd optimized XX" + if (CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4) + # Modern CMake: + SET(OpenCV_LIBS ${OpenCV_LIBS} debug ${__CVLIB}@OPENCV_DLLVERSION@@OPENCV_DEBUG_POSTFIX@ optimized ${__CVLIB}@OPENCV_DLLVERSION@) + else(CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4) + # Old CMake: + SET(OpenCV_LIBS ${OpenCV_LIBS} ${__CVLIB}@OPENCV_DLLVERSION@) + endif(CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4) endforeach(__CVLIB) # ============================================================== # Extra include directories, needed by OpenCV 2 new structure # ============================================================== if(NOT @CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@ STREQUAL "") - SET(BASEDIR @CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@) - foreach(__CVLIB ${OPENCV_LIB_COMPONENTS}) - # We only need the "core",... part here: "opencv_core" -> "core" - STRING(REGEX REPLACE "opencv_(.*)" "\\1" MODNAME ${__CVLIB}) - INCLUDE_DIRECTORIES("${BASEDIR}/modules/${MODNAME}/include") - endforeach(__CVLIB) + SET(BASEDIR @CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@) + foreach(__CVLIB ${OPENCV_LIB_COMPONENTS}) + # We only need the "core",... part here: "opencv_core" -> "core" + STRING(REGEX REPLACE "opencv_(.*)" "\\1" MODNAME ${__CVLIB}) + INCLUDE_DIRECTORIES("${BASEDIR}/modules/${MODNAME}/include") + endforeach(__CVLIB) endif(NOT @CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@ STREQUAL "") # For OpenCV built as static libs, we need the user to link against # many more dependencies: IF (NOT @OPENCV_BUILD_SHARED_LIB@) - # Under static libs, the user of OpenCV needs access to the 3rdparty libs as well: + # Under static libs, the user of OpenCV needs access to the 3rdparty libs as well: LINK_DIRECTORIES(@CMAKE_LIB_DIRS_CONFIGCMAKE@/../3rdparty/lib) if(WIN32) LINK_DIRECTORIES(@CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@/3rdparty/lib) @@ -98,13 +98,13 @@ IF (NOT @OPENCV_BUILD_SHARED_LIB@) LINK_DIRECTORIES(@CMAKE_LIB_DIRS_CONFIGCMAKE@/../share/opencv/3rdparty/lib) endif() - set(OpenCV_LIBS @OPENCV_LINKER_LIBS@ @IPP_LIBS@ @HIGHGUI_LIBRARIES@ ${OpenCV_LIBS}) + set(OpenCV_LIBS @OPENCV_LINKER_LIBS@ @IPP_LIBS@ @HIGHGUI_LIBRARIES@ ${OpenCV_LIBS}) - set(OPENCV_EXTRA_COMPONENTS @JPEG_LIBRARIES@ @PNG_LIBRARIES@ @TIFF_LIBRARIES@ @JASPER_LIBRARIES@ zlib opencv_lapack) + set(OPENCV_EXTRA_COMPONENTS @JPEG_LIBRARIES@ @PNG_LIBRARIES@ @TIFF_LIBRARIES@ @JASPER_LIBRARIES@ zlib) if (CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4) foreach(__EXTRA_LIB ${OPENCV_EXTRA_COMPONENTS}) - set(OpenCV_LIBS ${OpenCV_LIBS} + set(OpenCV_LIBS ${OpenCV_LIBS} debug ${__EXTRA_LIB}@OPENCV_DEBUG_POSTFIX@ optimized ${__EXTRA_LIB}) endforeach(__EXTRA_LIB) diff --git a/modules/core/CMakeLists.txt b/modules/core/CMakeLists.txt index b50a407..390fe69 100644 --- a/modules/core/CMakeLists.txt +++ b/modules/core/CMakeLists.txt @@ -1,3 +1,3 @@ include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../../3rdparty/include") -set(deps opencv_lapack zlib) +set(deps zlib) define_opencv_module(core ${deps})