-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()
+++ /dev/null
-/* 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 */
+++ /dev/null
-/* 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 */
+++ /dev/null
-/* f2c.h -- Standard Fortran to C header file */
-
-/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
-
- - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
-
-#ifndef F2C_INCLUDE
-#define F2C_INCLUDE
-
-#include <assert.h>
-#include <math.h>
-#include <ctype.h>
-#include <stdlib.h>
-/* needed for Windows Mobile */
-#ifdef WINCE
-#undef complex;
-#endif
-#include <string.h>
-#include <stdio.h>
-
-#if __SSE2__ || defined _M_X64
-#include "emmintrin.h"
-#endif
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-typedef int integer;
-typedef unsigned int uinteger;
-typedef char *address;
-typedef short int shortint;
-typedef float real;
-typedef double doublereal;
-typedef struct { real r, i; } complex;
-typedef struct { doublereal r, i; } doublecomplex;
-typedef int logical;
-typedef short int shortlogical;
-typedef char logical1;
-typedef char integer1;
-#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */
-typedef long long longint; /* system-dependent */
-typedef unsigned long long ulongint; /* system-dependent */
-#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b)))
-#define qbit_set(a,b) ((a) | ((ulongint)1 << (b)))
-#endif
-
-#define TRUE_ (1)
-#define FALSE_ (0)
-
-/* Extern is for use with -E */
-#ifndef Extern
-#define Extern extern
-#endif
-
-/* I/O stuff */
-
-#ifdef f2c_i2
-/* for -i2 */
-typedef short flag;
-typedef short ftnlen;
-typedef short ftnint;
-#else
-typedef int flag;
-typedef int ftnlen;
-typedef int ftnint;
-#endif
-
-/*external read, write*/
-typedef struct
-{ flag cierr;
- ftnint ciunit;
- flag ciend;
- char *cifmt;
- ftnint cirec;
-} cilist;
-
-/*internal read, write*/
-typedef struct
-{ flag icierr;
- char *iciunit;
- flag iciend;
- char *icifmt;
- ftnint icirlen;
- ftnint icirnum;
-} icilist;
-
-/*open*/
-typedef struct
-{ flag oerr;
- ftnint ounit;
- char *ofnm;
- ftnlen ofnmlen;
- char *osta;
- char *oacc;
- char *ofm;
- ftnint orl;
- char *oblnk;
-} olist;
-
-/*close*/
-typedef struct
-{ flag cerr;
- ftnint cunit;
- char *csta;
-} cllist;
-
-/*rewind, backspace, endfile*/
-typedef struct
-{ flag aerr;
- ftnint aunit;
-} alist;
-
-/* inquire */
-typedef struct
-{ flag inerr;
- ftnint inunit;
- char *infile;
- ftnlen infilen;
- ftnint *inex; /*parameters in standard's order*/
- ftnint *inopen;
- ftnint *innum;
- ftnint *innamed;
- char *inname;
- ftnlen innamlen;
- char *inacc;
- ftnlen inacclen;
- char *inseq;
- ftnlen inseqlen;
- char *indir;
- ftnlen indirlen;
- char *infmt;
- ftnlen infmtlen;
- char *inform;
- ftnint informlen;
- char *inunf;
- ftnlen inunflen;
- ftnint *inrecl;
- ftnint *innrec;
- char *inblank;
- ftnlen inblanklen;
-} inlist;
-
-#define VOID void
-
-union Multitype { /* for multiple entry points */
- integer1 g;
- shortint h;
- integer i;
- /* longint j; */
- real r;
- doublereal d;
- complex c;
- doublecomplex z;
- };
-
-typedef union Multitype Multitype;
-
-/*typedef long int Long;*/ /* No longer used; formerly in Namelist */
-
-struct Vardesc { /* for Namelist */
- char *name;
- char *addr;
- ftnlen *dims;
- int type;
- };
-typedef struct Vardesc Vardesc;
-
-struct Namelist {
- char *name;
- Vardesc **vars;
- int nvars;
- };
-typedef struct Namelist Namelist;
-
-#ifndef abs
-#define abs(x) ((x) >= 0 ? (x) : -(x))
-#endif
-#define dabs(x) (doublereal)abs(x)
-#ifndef min
-#define min(a,b) ((a) <= (b) ? (a) : (b))
-#endif
-#ifndef max
-#define max(a,b) ((a) >= (b) ? (a) : (b))
-#endif
-#define dmin(a,b) (doublereal)min(a,b)
-#define dmax(a,b) (doublereal)max(a,b)
-#define bit_test(a,b) ((a) >> (b) & 1)
-#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
-#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
-
-/* procedure parameter types for -A and -C++ */
-
-#define F2C_proc_par_types 1
-#ifdef __cplusplus
-typedef int /* Unknown procedure type */ (*U_fp)(...);
-typedef shortint (*J_fp)(...);
-typedef integer (*I_fp)(...);
-typedef real (*R_fp)(...);
-typedef doublereal (*D_fp)(...), (*E_fp)(...);
-typedef /* Complex */ VOID (*C_fp)(...);
-typedef /* Double Complex */ VOID (*Z_fp)(...);
-typedef logical (*L_fp)(...);
-typedef shortlogical (*K_fp)(...);
-typedef /* Character */ VOID (*H_fp)(...);
-typedef /* Subroutine */ int (*S_fp)(...);
-#else
-typedef int /* Unknown procedure type */ (*U_fp)();
-typedef shortint (*J_fp)();
-typedef integer (*I_fp)();
-typedef real (*R_fp)();
-typedef doublereal (*D_fp)(), (*E_fp)();
-typedef /* Complex */ VOID (*C_fp)();
-typedef /* Double Complex */ VOID (*Z_fp)();
-typedef logical (*L_fp)();
-typedef shortlogical (*K_fp)();
-typedef /* Character */ VOID (*H_fp)();
-typedef /* Subroutine */ int (*S_fp)();
-#endif
-/* E_fp is for real functions when -R is not specified */
-typedef VOID C_f; /* complex function */
-typedef VOID H_f; /* character function */
-typedef VOID Z_f; /* double complex function */
-typedef doublereal E_f; /* real function with -R not specified */
-
-/* undef any lower-case symbols that your C compiler predefines, e.g.: */
-
-#ifndef Skip_f2c_Undefs
-#undef cray
-#undef gcos
-#undef mc68010
-#undef mc68020
-#undef mips
-#undef pdp11
-#undef sgi
-#undef sparc
-#undef sun
-#undef sun2
-#undef sun3
-#undef sun4
-#undef u370
-#undef u3b
-#undef u3b2
-#undef u3b5
-#undef unix
-#undef vax
-#endif
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
+++ /dev/null
-# ----------------------------------------------------------------------------
-# 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()
+++ /dev/null
-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.
-
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#include "clapack.h"
-#include <float.h>
-#include <stdio.h>
-
-/* *********************************************************************** */
-
-doublereal dlamc3_(doublereal *a, doublereal *b)
-{
- /* System generated locals */
- doublereal ret_val;
-
-
- /* -- LAPACK auxiliary routine (version 3.1) -- */
- /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
- /* November 2006 */
-
- /* .. Scalar Arguments .. */
- /* .. */
-
- /* Purpose */
- /* ======= */
-
- /* DLAMC3 is intended to force A and B to be stored prior to doing */
- /* the addition of A and B , for use in situations where optimizers */
- /* might hold one of these in a register. */
-
- /* Arguments */
- /* ========= */
-
- /* A (input) DOUBLE PRECISION */
- /* B (input) DOUBLE PRECISION */
- /* The values A and B. */
-
- /* ===================================================================== */
-
- /* .. Executable Statements .. */
-
- ret_val = *a + *b;
-
- return ret_val;
-
- /* End of DLAMC3 */
-
-} /* dlamc3_ */
-
-
-/* simpler version of dlamch for the case of IEEE754-compliant FPU module by Piotr Luszczek S.
- taken from http://www.mail-archive.com/numpy-discussion@lists.sourceforge.net/msg02448.html */
-
-#ifndef DBL_DIGITS
-#define DBL_DIGITS 53
-#endif
-
-const doublereal lapack_dlamch_tab[] =
-{
- 0, FLT_RADIX, DBL_EPSILON, DBL_MAX_EXP, DBL_MIN_EXP, DBL_DIGITS, DBL_MAX,
- DBL_EPSILON*FLT_RADIX, 1, DBL_MIN*(1 + DBL_EPSILON), DBL_MIN
-};
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#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;
-}
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#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);
-}
+++ /dev/null
-#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);
-}
+++ /dev/null
-#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);
-}
+++ /dev/null
-#include "clapack.h"
+++ /dev/null
-/* 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);
- }
-}
+++ /dev/null
-#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);
-}
+++ /dev/null
-/* 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++ = ' ';
- }
-}
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#include "clapack.h"
-#include <assert.h>
-
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#include "clapack.h"
-#include <float.h>
-#include <stdio.h>
-
-/* *********************************************************************** */
-
-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
-};
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-#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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
+++ /dev/null
-/* 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_ */
http://muonics.net/school/spring05/videoInput/\r
\r
------------------------------------------------------------------------------------\r
-\r
-clapack-3.2.1 - F2C translation of the Linear Algebra PACKage (LAPACK),\r
- Copyright (c) 1992-2010 The University of Tennessee. All rights reserved.\r
- http://www.netlib.org/lapack/\r
- http://www.netlib.org/clapack/\r
-\r
- Note, that only a subset of package is used in OpenCV.\r
- It can be extended and/or replaced with future upstream releases\r
- in the future.\r
-\r
-------------------------------------------------------------------------------------\r
\r
# ====================================================================\r
# Link libraries: e.g. opencv_core220.so, opencv_imgproc220d.lib, etc...\r
-# ====================================================================
+# ====================================================================\r
if(NOT ANDROID)\r
- 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\r
- set(OPENCV_LIB_COMPONENTS opencv_calib3d opencv_objdetect opencv_features2d opencv_imgproc opencv_video opencv_highgui opencv_ml opencv_legacy opencv_flann opencv_core )\r
-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)\r
+else()\r
+ #libraries order is very important because linker from Android NDK is one-pass linker\r
+ set(OPENCV_LIB_COMPONENTS opencv_calib3d opencv_objdetect opencv_features2d opencv_imgproc opencv_video opencv_highgui opencv_ml opencv_legacy opencv_flann opencv_core )\r
+endif()\r
\r
SET(OpenCV_LIBS "")\r
foreach(__CVLIB ${OPENCV_LIB_COMPONENTS})\r
- # CMake>=2.6 supports the notation "debug XXd optimized XX"\r
- if (CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4)\r
- # Modern CMake:\r
- SET(OpenCV_LIBS ${OpenCV_LIBS} debug ${__CVLIB}@OPENCV_DLLVERSION@@OPENCV_DEBUG_POSTFIX@ optimized ${__CVLIB}@OPENCV_DLLVERSION@)\r
- else(CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4)\r
- # Old CMake:\r
- SET(OpenCV_LIBS ${OpenCV_LIBS} ${__CVLIB}@OPENCV_DLLVERSION@)\r
- endif(CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4)\r
+ # CMake>=2.6 supports the notation "debug XXd optimized XX"\r
+ if (CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4)\r
+ # Modern CMake:\r
+ SET(OpenCV_LIBS ${OpenCV_LIBS} debug ${__CVLIB}@OPENCV_DLLVERSION@@OPENCV_DEBUG_POSTFIX@ optimized ${__CVLIB}@OPENCV_DLLVERSION@)\r
+ else(CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4)\r
+ # Old CMake:\r
+ SET(OpenCV_LIBS ${OpenCV_LIBS} ${__CVLIB}@OPENCV_DLLVERSION@)\r
+ endif(CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4)\r
endforeach(__CVLIB)\r
\r
# ==============================================================\r
# Extra include directories, needed by OpenCV 2 new structure\r
# ==============================================================\r
if(NOT @CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@ STREQUAL "")\r
- SET(BASEDIR @CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@)\r
- foreach(__CVLIB ${OPENCV_LIB_COMPONENTS})\r
- # We only need the "core",... part here: "opencv_core" -> "core"\r
- STRING(REGEX REPLACE "opencv_(.*)" "\\1" MODNAME ${__CVLIB})\r
- INCLUDE_DIRECTORIES("${BASEDIR}/modules/${MODNAME}/include")\r
- endforeach(__CVLIB)\r
+ SET(BASEDIR @CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@)\r
+ foreach(__CVLIB ${OPENCV_LIB_COMPONENTS})\r
+ # We only need the "core",... part here: "opencv_core" -> "core"\r
+ STRING(REGEX REPLACE "opencv_(.*)" "\\1" MODNAME ${__CVLIB})\r
+ INCLUDE_DIRECTORIES("${BASEDIR}/modules/${MODNAME}/include")\r
+ endforeach(__CVLIB)\r
endif(NOT @CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@ STREQUAL "")\r
\r
# For OpenCV built as static libs, we need the user to link against\r
# many more dependencies:\r
IF (NOT @OPENCV_BUILD_SHARED_LIB@)\r
- # Under static libs, the user of OpenCV needs access to the 3rdparty libs as well:\r
+ # Under static libs, the user of OpenCV needs access to the 3rdparty libs as well:\r
LINK_DIRECTORIES(@CMAKE_LIB_DIRS_CONFIGCMAKE@/../3rdparty/lib)\r
if(WIN32)\r
LINK_DIRECTORIES(@CMAKE_BASE_INCLUDE_DIRS_CONFIGCMAKE@/3rdparty/lib)\r
LINK_DIRECTORIES(@CMAKE_LIB_DIRS_CONFIGCMAKE@/../share/opencv/3rdparty/lib)\r
endif() \r
\r
- set(OpenCV_LIBS @OPENCV_LINKER_LIBS@ @IPP_LIBS@ @HIGHGUI_LIBRARIES@ ${OpenCV_LIBS})\r
+ set(OpenCV_LIBS @OPENCV_LINKER_LIBS@ @IPP_LIBS@ @HIGHGUI_LIBRARIES@ ${OpenCV_LIBS})\r
\r
- set(OPENCV_EXTRA_COMPONENTS @JPEG_LIBRARIES@ @PNG_LIBRARIES@ @TIFF_LIBRARIES@ @JASPER_LIBRARIES@ zlib opencv_lapack)\r
+ set(OPENCV_EXTRA_COMPONENTS @JPEG_LIBRARIES@ @PNG_LIBRARIES@ @TIFF_LIBRARIES@ @JASPER_LIBRARIES@ zlib)\r
\r
if (CMAKE_MAJOR_VERSION GREATER 2 OR CMAKE_MINOR_VERSION GREATER 4)\r
foreach(__EXTRA_LIB ${OPENCV_EXTRA_COMPONENTS})\r
- set(OpenCV_LIBS ${OpenCV_LIBS}\r
+ set(OpenCV_LIBS ${OpenCV_LIBS}\r
debug ${__EXTRA_LIB}@OPENCV_DEBUG_POSTFIX@\r
optimized ${__EXTRA_LIB})\r
endforeach(__EXTRA_LIB)\r
include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../../3rdparty/include")
-set(deps opencv_lapack zlib)
+set(deps zlib)
define_opencv_module(core ${deps})
projects / profile / ivi / opencv.git / commitdiff