diff --git a/3rdparty/clapack/CMakeLists.txt b/3rdparty/clapack/CMakeLists.txt new file mode 100644 index 0000000000..fc28713b0a --- /dev/null +++ b/3rdparty/clapack/CMakeLists.txt @@ -0,0 +1,48 @@ +# ---------------------------------------------------------------------------- +# CMake file for opencv_lapack. See root CMakeLists.txt +# +# ---------------------------------------------------------------------------- +project(clapack) + +# TODO: extract it from sources somehow +set(CLAPACK_VERSION "3.9.0" PARENT_SCOPE) + +include_directories("${CMAKE_CURRENT_SOURCE_DIR}/include") + +# The .cpp files: +file(GLOB lapack_srcs src/*.c) +file(GLOB runtime_srcs runtime/*.c) +file(GLOB lib_hdrs include/*.h) + +# ---------------------------------------------------------------------------------- +# Define the library target: +# ---------------------------------------------------------------------------------- + +set(the_target "libclapack") + +add_library(${the_target} STATIC ${lapack_srcs} ${runtime_srcs} ${lib_hdrs}) + +ocv_warnings_disable(CMAKE_C_FLAGS -Wno-parentheses -Wno-uninitialized -Wno-array-bounds + -Wno-implicit-function-declaration -Wno-unused -Wunused-parameter) # gcc/clang warnings +ocv_warnings_disable(CMAKE_C_FLAGS /wd4244 /wd4554 /wd4723) # visual studio warnings + +set_target_properties(${the_target} + PROPERTIES OUTPUT_NAME ${the_target} + DEBUG_POSTFIX "${OPENCV_DEBUG_POSTFIX}" + COMPILE_PDB_NAME ${the_target} + COMPILE_PDB_NAME_DEBUG "${the_target}${OPENCV_DEBUG_POSTFIX}" + ARCHIVE_OUTPUT_DIRECTORY ${3P_LIBRARY_OUTPUT_PATH} + ) + +set(CLAPACK_INCLUDE_DIR "${CMAKE_CURRENT_SOURCE_DIR}/include" PARENT_SCOPE) +set(CLAPACK_LIBRARIES ${the_target} PARENT_SCOPE) + +if(ENABLE_SOLUTION_FOLDERS) + set_target_properties(${the_target} PROPERTIES FOLDER "3rdparty") +endif() + +if(NOT BUILD_SHARED_LIBS) + ocv_install_target(${the_target} EXPORT OpenCVModules ARCHIVE DESTINATION ${OPENCV_3P_LIB_INSTALL_PATH} COMPONENT dev) +endif() + +ocv_install_3rdparty_licenses(clapack lapack_LICENSE) diff --git a/3rdparty/clapack/include/cblas.h b/3rdparty/clapack/include/cblas.h new file mode 100644 index 0000000000..56cc49b7c7 --- /dev/null +++ b/3rdparty/clapack/include/cblas.h @@ -0,0 +1,102 @@ +#ifndef __CBLAS_H__ +#define __CBLAS_H__ + +/* most of the stuff is in lapacke.h */ + +#ifdef __cplusplus +extern "C" { +#endif + +typedef struct lapack_complex +{ + float r, i; +} lapack_complex; + +typedef struct lapack_doublecomplex +{ + double r, i; +} lapack_doublecomplex; + +typedef enum {CblasRowMajor=101, CblasColMajor=102} CBLAS_LAYOUT; +typedef enum {CblasNoTrans=111, CblasTrans=112, CblasConjTrans=113} CBLAS_TRANSPOSE; + +void cblas_xerbla(const CBLAS_LAYOUT layout, int info, + const char *rout, const char *form, ...); + +void cblas_sgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const float alpha, const float *A, + const int lda, const float *B, const int ldb, + const float beta, float *C, const int ldc); + +void cblas_dgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const double alpha, const double *A, + const int lda, const double *B, const int ldb, + const double beta, double *C, const int ldc); + +void cblas_cgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc); + +void cblas_zgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc); + +int xerbla_(char *, int *); +int lsame_(char *, char *); +double slamch_(char* cmach); +double slamc3_(float *a, float *b); +double dlamch_(char* cmach); +double dlamc3_(double *a, double *b); + +int dgels_(char *trans, int *m, int *n, int *nrhs, double *a, + int *lda, double *b, int *ldb, double *work, int *lwork, int *info); + +int dgesv_(int *n, int *nrhs, double *a, int *lda, int *ipiv, + double *b, int *ldb, int *info); + +int dgetrf_(int *m, int *n, double *a, int *lda, int *ipiv, + int *info); + +int dposv_(char *uplo, int *n, int *nrhs, double *a, int * + lda, double *b, int *ldb, int *info); + +int dpotrf_(char *uplo, int *n, double *a, int *lda, int * + info); + +int sgels_(char *trans, int *m, int *n, int *nrhs, float *a, + int *lda, float *b, int *ldb, float *work, int *lwork, int *info); + +int sgeev_(char *jobvl, char *jobvr, int *n, float *a, int * + lda, float *wr, float *wi, float *vl, int *ldvl, float *vr, int * + ldvr, float *work, int *lwork, int *info); + +int sgeqrf_(int *m, int *n, float *a, int *lda, float *tau, + float *work, int *lwork, int *info); + +int sgesv_(int *n, int *nrhs, float *a, int *lda, int *ipiv, + float *b, int *ldb, int *info); + +int sgetrf_(int *m, int *n, float *a, int *lda, int *ipiv, + int *info); + +int sposv_(char *uplo, int *n, int *nrhs, float *a, int * + lda, float *b, int *ldb, int *info); + +int spotrf_(char *uplo, int *n, float *a, int *lda, int * + info); + +int sgesdd_(char *jobz, int *m, int *n, float *a, int *lda, + float *s, float *u, int *ldu, float *vt, int *ldvt, float *work, + int *lwork, int *iwork, int *info); + +#ifdef __cplusplus +} +#endif + +#endif /* __CBLAS_H__ */ diff --git a/3rdparty/clapack/include/f2c.h b/3rdparty/clapack/include/f2c.h new file mode 100644 index 0000000000..c832b0fe0b --- /dev/null +++ b/3rdparty/clapack/include/f2c.h @@ -0,0 +1,129 @@ +/* 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_H__ +#define __F2C_H__ + +#include +#include +#include +#include +#include +#include + +#include "cblas.h" +#include "lapack.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#undef complex + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef lapack_complex complex; +typedef lapack_doublecomplex doublecomplex; +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +#ifndef abs +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#endif +#define dabs(x) (double)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) (double)min(a,b) +#define dmax(a,b) (double)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))) + +static __inline double r_lg10(float *x) +{ + return 0.43429448190325182765*log(*x); +} + +static __inline double d_lg10(double *x) +{ + return 0.43429448190325182765*log(*x); +} + +static __inline double d_sign(double *a, double *b) +{ + double x = fabs(*a); + return *b >= 0 ? x : -x; +} + +static __inline double r_sign(float *a, float *b) +{ + double x = fabs((double)*a); + return *b >= 0 ? x : -x; +} + +static __inline int i_nint(float *x) +{ + return (int)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} + +int pow_ii(int *ap, int *bp); +double pow_di(double *ap, int *bp); +static __inline double pow_ri(float *ap, int *bp) +{ + double apd = *ap; + return pow_di(&apd, bp); +} +static __inline double pow_dd(double *ap, double *bp) +{ + return pow(*ap, *bp); +} + +static __inline void d_cnjg(doublecomplex *r, doublecomplex *z) +{ + double zi = z->i; + r->r = z->r; + r->i = -zi; +} + +static __inline void r_cnjg(complex *r, complex *z) +{ + float zi = z->i; + r->r = z->r; + r->i = -zi; +} + +static __inline int s_copy(char *a, char *b, int maxlen) +{ + strncpy(a, b, maxlen); + a[maxlen] = '\0'; + return 0; +} + +int s_cat(char *lp, char **rpp, int* rnp, int *np); +int s_cmp(char *a0, char *b0); +static __inline int i_len(char* s) +{ + return (int)strlen(s); +} + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/3rdparty/clapack/include/lapack.h b/3rdparty/clapack/include/lapack.h new file mode 100644 index 0000000000..3f89d223f1 --- /dev/null +++ b/3rdparty/clapack/include/lapack.h @@ -0,0 +1,381 @@ +// this is auto-generated header for Lapack subset +#ifndef __CLAPACK_H__ +#define __CLAPACK_H__ + +#include "cblas.h" + +#ifdef __cplusplus +extern "C" { +#endif + +int cgemm_(char *transa, char *transb, int *m, int *n, int * + k, lapack_complex *alpha, lapack_complex *a, int *lda, lapack_complex *b, int *ldb, + lapack_complex *beta, lapack_complex *c__, int *ldc); + +int daxpy_(int *n, double *da, double *dx, int *incx, double + *dy, int *incy); + +int dbdsdc_(char *uplo, char *compq, int *n, double *d__, + double *e, double *u, int *ldu, double *vt, int *ldvt, double *q, int + *iq, double *work, int *iwork, int *info); + +int dbdsqr_(char *uplo, int *n, int *ncvt, int *nru, int * + ncc, double *d__, double *e, double *vt, int *ldvt, double *u, int * + ldu, double *c__, int *ldc, double *work, int *info); + +int dcombssq_(double *v1, double *v2); + +int dcopy_(int *n, double *dx, int *incx, double *dy, int * + incy); + +double ddot_(int *n, double *dx, int *incx, double *dy, int *incy); + +int dgebak_(char *job, char *side, int *n, int *ilo, int * + ihi, double *scale, int *m, double *v, int *ldv, int *info); + +int dgebal_(char *job, int *n, double *a, int *lda, int *ilo, + int *ihi, double *scale, int *info); + +int dgebd2_(int *m, int *n, double *a, int *lda, double *d__, + double *e, double *tauq, double *taup, double *work, int *info); + +int dgebrd_(int *m, int *n, double *a, int *lda, double *d__, + double *e, double *tauq, double *taup, double *work, int *lwork, int + *info); + +int dgeev_(char *jobvl, char *jobvr, int *n, double *a, int * + lda, double *wr, double *wi, double *vl, int *ldvl, double *vr, int * + ldvr, double *work, int *lwork, int *info); + +int dgehd2_(int *n, int *ilo, int *ihi, double *a, int *lda, + double *tau, double *work, int *info); + +int dgehrd_(int *n, int *ilo, int *ihi, double *a, int *lda, + double *tau, double *work, int *lwork, int *info); + +int dgelq2_(int *m, int *n, double *a, int *lda, double *tau, + double *work, int *info); + +int dgelqf_(int *m, int *n, double *a, int *lda, double *tau, + double *work, int *lwork, int *info); + +int dgemm_(char *transa, char *transb, int *m, int *n, int * + k, double *alpha, double *a, int *lda, double *b, int *ldb, double * + beta, double *c__, int *ldc); + +int dgemv_(char *trans, int *m, int *n, double *alpha, + double *a, int *lda, double *x, int *incx, double *beta, double *y, + int *incy); + +int dgeqr2_(int *m, int *n, double *a, int *lda, double *tau, + double *work, int *info); + +int dgeqrf_(int *m, int *n, double *a, int *lda, double *tau, + double *work, int *lwork, int *info); + +int dger_(int *m, int *n, double *alpha, double *x, int * + incx, double *y, int *incy, double *a, int *lda); + +int dgesdd_(char *jobz, int *m, int *n, double *a, int *lda, + double *s, double *u, int *ldu, double *vt, int *ldvt, double *work, + int *lwork, int *iwork, int *info); + +int dhseqr_(char *job, char *compz, int *n, int *ilo, int * + ihi, double *h__, int *ldh, double *wr, double *wi, double *z__, int * + ldz, double *work, int *lwork, int *info); + +int disnan_(double *din); + +int dlabad_(double *small, double *large); + +int dlabrd_(int *m, int *n, int *nb, double *a, int *lda, + double *d__, double *e, double *tauq, double *taup, double *x, int * + ldx, double *y, int *ldy); + +int dlacpy_(char *uplo, int *m, int *n, double *a, int *lda, + double *b, int *ldb); + +int dladiv1_(double *a, double *b, double *c__, double *d__, + double *p, double *q); + +double dladiv2_(double *a, double *b, double *c__, double *d__, double *r__, + double *t); + +int dladiv_(double *a, double *b, double *c__, double *d__, + double *p, double *q); + +int dlaed6_(int *kniter, int *orgati, double *rho, double * + d__, double *z__, double *finit, double *tau, int *info); + +int dlaexc_(int *wantq, int *n, double *t, int *ldt, double * + q, int *ldq, int *j1, int *n1, int *n2, double *work, int *info); + +int dlahqr_(int *wantt, int *wantz, int *n, int *ilo, int * + ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int * + ihiz, double *z__, int *ldz, int *info); + +int dlahr2_(int *n, int *k, int *nb, double *a, int *lda, + double *tau, double *t, int *ldt, double *y, int *ldy); + +int dlaisnan_(double *din1, double *din2); + +int dlaln2_(int *ltrans, int *na, int *nw, double *smin, + double *ca, double *a, int *lda, double *d1, double *d2, double *b, + int *ldb, double *wr, double *wi, double *x, int *ldx, double *scale, + double *xnorm, int *info); + +int dlamrg_(int *n1, int *n2, double *a, int *dtrd1, int * + dtrd2, int *index); + +double dlange_(char *norm, int *m, int *n, double *a, int *lda, double *work); + +double dlanst_(char *norm, int *n, double *d__, double *e); + +int dlanv2_(double *a, double *b, double *c__, double *d__, + double *rt1r, double *rt1i, double *rt2r, double *rt2i, double *cs, + double *sn); + +double dlapy2_(double *x, double *y); + +int dlaqr0_(int *wantt, int *wantz, int *n, int *ilo, int * + ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int * + ihiz, double *z__, int *ldz, double *work, int *lwork, int *info); + +int dlaqr1_(int *n, double *h__, int *ldh, double *sr1, + double *si1, double *sr2, double *si2, double *v); + +int dlaqr2_(int *wantt, int *wantz, int *n, int *ktop, int * + kbot, int *nw, double *h__, int *ldh, int *iloz, int *ihiz, double * + z__, int *ldz, int *ns, int *nd, double *sr, double *si, double *v, + int *ldv, int *nh, double *t, int *ldt, int *nv, double *wv, int * + ldwv, double *work, int *lwork); + +int dlaqr3_(int *wantt, int *wantz, int *n, int *ktop, int * + kbot, int *nw, double *h__, int *ldh, int *iloz, int *ihiz, double * + z__, int *ldz, int *ns, int *nd, double *sr, double *si, double *v, + int *ldv, int *nh, double *t, int *ldt, int *nv, double *wv, int * + ldwv, double *work, int *lwork); + +int dlaqr4_(int *wantt, int *wantz, int *n, int *ilo, int * + ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int * + ihiz, double *z__, int *ldz, double *work, int *lwork, int *info); + +int dlaqr5_(int *wantt, int *wantz, int *kacc22, int *n, int + *ktop, int *kbot, int *nshfts, double *sr, double *si, double *h__, + int *ldh, int *iloz, int *ihiz, double *z__, int *ldz, double *v, int + *ldv, double *u, int *ldu, int *nv, double *wv, int *ldwv, int *nh, + double *wh, int *ldwh); + +int dlarf_(char *side, int *m, int *n, double *v, int *incv, + double *tau, double *c__, int *ldc, double *work); + +int dlarfb_(char *side, char *trans, char *direct, char * + storev, int *m, int *n, int *k, double *v, int *ldv, double *t, int * + ldt, double *c__, int *ldc, double *work, int *ldwork); + +int dlarfg_(int *n, double *alpha, double *x, int *incx, + double *tau); + +int dlarft_(char *direct, char *storev, int *n, int *k, + double *v, int *ldv, double *tau, double *t, int *ldt); + +int dlarfx_(char *side, int *m, int *n, double *v, double * + tau, double *c__, int *ldc, double *work); + +int dlartg_(double *f, double *g, double *cs, double *sn, + double *r__); + +int dlas2_(double *f, double *g, double *h__, double *ssmin, + double *ssmax); + +int dlascl_(char *type__, int *kl, int *ku, double *cfrom, + double *cto, int *m, int *n, double *a, int *lda, int *info); + +int dlasd0_(int *n, int *sqre, double *d__, double *e, + double *u, int *ldu, double *vt, int *ldvt, int *smlsiz, int *iwork, + double *work, int *info); + +int dlasd1_(int *nl, int *nr, int *sqre, double *d__, double + *alpha, double *beta, double *u, int *ldu, double *vt, int *ldvt, int + *idxq, int *iwork, double *work, int *info); + +int dlasd2_(int *nl, int *nr, int *sqre, int *k, double *d__, + double *z__, double *alpha, double *beta, double *u, int *ldu, + double *vt, int *ldvt, double *dsigma, double *u2, int *ldu2, double * + vt2, int *ldvt2, int *idxp, int *idx, int *idxc, int *idxq, int * + coltyp, int *info); + +int dlasd3_(int *nl, int *nr, int *sqre, int *k, double *d__, + double *q, int *ldq, double *dsigma, double *u, int *ldu, double *u2, + int *ldu2, double *vt, int *ldvt, double *vt2, int *ldvt2, int *idxc, + int *ctot, double *z__, int *info); + +int dlasd4_(int *n, int *i__, double *d__, double *z__, + double *delta, double *rho, double *sigma, double *work, int *info); + +int dlasd5_(int *i__, double *d__, double *z__, double * + delta, double *rho, double *dsigma, double *work); + +int dlasd6_(int *icompq, int *nl, int *nr, int *sqre, double + *d__, double *vf, double *vl, double *alpha, double *beta, int *idxq, + int *perm, int *givptr, int *givcol, int *ldgcol, double *givnum, int + *ldgnum, double *poles, double *difl, double *difr, double *z__, int * + k, double *c__, double *s, double *work, int *iwork, int *info); + +int dlasd7_(int *icompq, int *nl, int *nr, int *sqre, int *k, + double *d__, double *z__, double *zw, double *vf, double *vfw, + double *vl, double *vlw, double *alpha, double *beta, double *dsigma, + int *idx, int *idxp, int *idxq, int *perm, int *givptr, int *givcol, + int *ldgcol, double *givnum, int *ldgnum, double *c__, double *s, int + *info); + +int dlasd8_(int *icompq, int *k, double *d__, double *z__, + double *vf, double *vl, double *difl, double *difr, int *lddifr, + double *dsigma, double *work, int *info); + +int dlasda_(int *icompq, int *smlsiz, int *n, int *sqre, + double *d__, double *e, double *u, int *ldu, double *vt, int *k, + double *difl, double *difr, double *z__, double *poles, int *givptr, + int *givcol, int *ldgcol, int *perm, double *givnum, double *c__, + double *s, double *work, int *iwork, int *info); + +int dlasdq_(char *uplo, int *sqre, int *n, int *ncvt, int * + nru, int *ncc, double *d__, double *e, double *vt, int *ldvt, double * + u, int *ldu, double *c__, int *ldc, double *work, int *info); + +int dlasdt_(int *n, int *lvl, int *nd, int *inode, int * + ndiml, int *ndimr, int *msub); + +int dlaset_(char *uplo, int *m, int *n, double *alpha, + double *beta, double *a, int *lda); + +int dlasq1_(int *n, double *d__, double *e, double *work, + int *info); + +int dlasq2_(int *n, double *z__, int *info); + +int dlasq3_(int *i0, int *n0, double *z__, int *pp, double * + dmin__, double *sigma, double *desig, double *qmax, int *nfail, int * + iter, int *ndiv, int *ieee, int *ttype, double *dmin1, double *dmin2, + double *dn, double *dn1, double *dn2, double *g, double *tau); + +int dlasq4_(int *i0, int *n0, double *z__, int *pp, int * + n0in, double *dmin__, double *dmin1, double *dmin2, double *dn, + double *dn1, double *dn2, double *tau, int *ttype, double *g); + +int dlasq5_(int *i0, int *n0, double *z__, int *pp, double * + tau, double *sigma, double *dmin__, double *dmin1, double *dmin2, + double *dn, double *dnm1, double *dnm2, int *ieee, double *eps); + +int dlasq6_(int *i0, int *n0, double *z__, int *pp, double * + dmin__, double *dmin1, double *dmin2, double *dn, double *dnm1, + double *dnm2); + +int dlasr_(char *side, char *pivot, char *direct, int *m, + int *n, double *c__, double *s, double *a, int *lda); + +int dlasrt_(char *id, int *n, double *d__, int *info); + +int dlassq_(int *n, double *x, int *incx, double *scale, + double *sumsq); + +int dlasv2_(double *f, double *g, double *h__, double *ssmin, + double *ssmax, double *snr, double *csr, double *snl, double *csl); + +int dlasy2_(int *ltranl, int *ltranr, int *isgn, int *n1, + int *n2, double *tl, int *ldtl, double *tr, int *ldtr, double *b, int + *ldb, double *scale, double *x, int *ldx, double *xnorm, int *info); + +double dnrm2_(int *n, double *x, int *incx); + +int dorg2r_(int *m, int *n, int *k, double *a, int *lda, + double *tau, double *work, int *info); + +int dorgbr_(char *vect, int *m, int *n, int *k, double *a, + int *lda, double *tau, double *work, int *lwork, int *info); + +int dorghr_(int *n, int *ilo, int *ihi, double *a, int *lda, + double *tau, double *work, int *lwork, int *info); + +int dorgl2_(int *m, int *n, int *k, double *a, int *lda, + double *tau, double *work, int *info); + +int dorglq_(int *m, int *n, int *k, double *a, int *lda, + double *tau, double *work, int *lwork, int *info); + +int dorgqr_(int *m, int *n, int *k, double *a, int *lda, + double *tau, double *work, int *lwork, int *info); + +int dorm2r_(char *side, char *trans, int *m, int *n, int *k, + double *a, int *lda, double *tau, double *c__, int *ldc, double *work, + int *info); + +int dormbr_(char *vect, char *side, char *trans, int *m, int + *n, int *k, double *a, int *lda, double *tau, double *c__, int *ldc, + double *work, int *lwork, int *info); + +int dormhr_(char *side, char *trans, int *m, int *n, int * + ilo, int *ihi, double *a, int *lda, double *tau, double *c__, int * + ldc, double *work, int *lwork, int *info); + +int dorml2_(char *side, char *trans, int *m, int *n, int *k, + double *a, int *lda, double *tau, double *c__, int *ldc, double *work, + int *info); + +int dormlq_(char *side, char *trans, int *m, int *n, int *k, + double *a, int *lda, double *tau, double *c__, int *ldc, double *work, + int *lwork, int *info); + +int dormqr_(char *side, char *trans, int *m, int *n, int *k, + double *a, int *lda, double *tau, double *c__, int *ldc, double *work, + int *lwork, int *info); + +int drot_(int *n, double *dx, int *incx, double *dy, int * + incy, double *c__, double *s); + +int dscal_(int *n, double *da, double *dx, int *incx); + +int dswap_(int *n, double *dx, int *incx, double *dy, int * + incy); + +int dtrevc3_(char *side, char *howmny, int *select, int *n, + double *t, int *ldt, double *vl, int *ldvl, double *vr, int *ldvr, + int *mm, int *m, double *work, int *lwork, int *info); + +int dtrexc_(char *compq, int *n, double *t, int *ldt, double + *q, int *ldq, int *ifst, int *ilst, double *work, int *info); + +int dtrmm_(char *side, char *uplo, char *transa, char *diag, + int *m, int *n, double *alpha, double *a, int *lda, double *b, int * + ldb); + +int dtrmv_(char *uplo, char *trans, char *diag, int *n, + double *a, int *lda, double *x, int *incx); + +int idamax_(int *n, double *dx, int *incx); + +int ieeeck_(int *ispec, float *zero, float *one); + +int iladlc_(int *m, int *n, double *a, int *lda); + +int iladlr_(int *m, int *n, double *a, int *lda); + +int ilaenv_(int *ispec, char *name__, char *opts, int *n1, int *n2, int *n3, + int *n4); + +int iparmq_(int *ispec, char *name__, char *opts, int *n, int *ilo, int *ihi, + int *lwork); + +int sgemm_(char *transa, char *transb, int *m, int *n, int * + k, float *alpha, float *a, int *lda, float *b, int *ldb, float *beta, + float *c__, int *ldc); + +int zgemm_(char *transa, char *transb, int *m, int *n, int * + k, lapack_doublecomplex *alpha, lapack_doublecomplex *a, int *lda, lapack_doublecomplex *b, + int *ldb, lapack_doublecomplex *beta, lapack_doublecomplex *c__, int *ldc); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/3rdparty/clapack/lapack_LICENSE b/3rdparty/clapack/lapack_LICENSE new file mode 100644 index 0000000000..94cdb0f85a --- /dev/null +++ b/3rdparty/clapack/lapack_LICENSE @@ -0,0 +1,48 @@ +Copyright (c) 1992-2017 The University of Tennessee and The University + of Tennessee Research Foundation. All rights + reserved. +Copyright (c) 2000-2017 The University of California Berkeley. All + rights reserved. +Copyright (c) 2006-2017 The University of Colorado Denver. 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. + +The copyright holders provide no reassurances that the source code +provided does not infringe any patent, copyright, or any other +intellectual property rights of third parties. The copyright holders +disclaim any liability to any recipient for claims brought against +recipient by any third party for infringement of that parties +intellectual property rights. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/3rdparty/clapack/make_clapack.py b/3rdparty/clapack/make_clapack.py new file mode 100644 index 0000000000..640cf5d96b --- /dev/null +++ b/3rdparty/clapack/make_clapack.py @@ -0,0 +1,272 @@ +appdoc = """ + This is generator of CLapack subset. + The usage: + + 1. Make sure you have the special version of f2c installed. + Grab it from https://github.com/vpisarev/f2c/tree/for_lapack. + 2. Download fresh version of Lapack from + https://github.com/Reference-LAPACK/lapack. + You may choose some specific version or the latest snapshot. + 3. If necessary, edit "roots" and "banlist" variables in this script, specify the needed and unneeded functions + 4. From within a working directory run + + $ python3 /3rdparty/clapack/make_clapack.py + or + $ F2C= python3 /3rdparty/clapack/make_clapack.py + + it will generate "new_clapack" directory with "include" and "src" subdirectories. + 5. erase opencv/3rdparty/clapack/src and replace it with new_clapack/src. + 6. copy new_clapack/include/lapack.h to opencv/3rdparty/clapack/include. + 7. optionally, edit opencv/3rdparty/clapack/CMakeLists.txt and update CLAPACK_VERSION as needed. + + This is it. Now build it and enjoy. +""" + +import glob, re, os, shutil, subprocess, sys + +roots = ["cgemm_", "dgemm_", "sgemm_", "zgemm_", + "dgeev_", "dgesdd_", + #"dsyevr_", + #"dgesv_", "dgetrf_", "dposv_", "dpotrf_", "dgels_", "dgeqrf_", + #"sgesv_", "sgetrf_", "sposv_", "spotrf_", "sgels_", "sgeqrf_" + ] +banlist = ["slamch_", "slamc3_", "dlamch_", "dlamc3_", "lsame_", "xerbla_"] + +if len(sys.argv) < 2: + print(appdoc) + sys.exit(0) + +lapack_root = sys.argv[1] +dst_path = "." + +def error(msg): + print ("error: " + msg) + sys.exit(0) + +def file2fun(fname): + return (os.path.basename(fname)[:-2]).upper() + +def print_graph(m): + for (k, neighbors) in sorted(m.items()): + print (k + " : " + ", ".join(sorted(list(neighbors)))) + +blas_path = os.path.join(lapack_root, "BLAS/SRC") +lapack_path = os.path.join(lapack_root, "SRC") + +roots = [f[:-1].upper() for f in roots] +banlist = [f[:-1].upper() for f in banlist] + +def fun2file(func): + filename = func.lower() + ".f" + blas_loc = blas_path + "/" + filename + lapack_loc = lapack_path + "/" + filename + if os.path.exists(blas_loc): + return blas_loc + elif os.path.exists(lapack_loc): + return lapack_loc + else: + error("neither %s nor %s exist" % (blas_loc, lapack_loc)) + +all_files = glob.glob(blas_path + "/*.f") + glob.glob(lapack_path + "/*.f") +all_funcs = [file2fun(fname) for fname in all_files] +all_funcs_set = set(all_funcs).difference(set(banlist)) +all_funcs = sorted(list(all_funcs_set)) + +func_deps = {} + +#print all_funcs + +words_regexp = re.compile(r'\w+') + +def scan_deps(func): + global func_deps + if func in func_deps: + return + func_deps[func] = set([]) # to avoid possibly infinite recursion + f = open(fun2file(func), 'rt') + deps = [] + external_mode = False + for l in f.readlines(): + if l.startswith('*'): + continue + l = l.strip().upper() + if l.startswith('EXTERNAL '): + external_mode = True + elif l.startswith('$') and external_mode: + pass + else: + external_mode = False + if not external_mode: + continue + for w in words_regexp.findall(l): + if w in all_funcs_set: + deps.append(w) + f.close() + # remove func from its dependencies + deps = set(deps).difference(set([func])) + func_deps[func] = deps + for d in deps: + scan_deps(d) + +for r in roots: + scan_deps(r) + +selected_funcs = sorted(func_deps.keys()) +print ("total files before amalgamation: %d" % len(selected_funcs)) + +inv_deps = {} +for func in selected_funcs: + inv_deps[func] = set([]) + +for (func, deps) in func_deps.items(): + for d in deps: + inv_deps[d] = inv_deps[d].union(set([func])) + +#print_graph(inv_deps) + +func_home = {} +for func in selected_funcs: + func_home[func] = func + +def get_home0(func, func0): + used_by = inv_deps[func] + if len(used_by) == 1: + p = list(used_by)[0] + if p != func and p != func0: + return get_home0(p, func0) + return func + return func + +# try to merge some files +for func in selected_funcs: + func_home[func] = get_home0(func, func) + +# try to merge some files even more +for iters in range(100): + homes_changed = False + for (func, used_by) in inv_deps.items(): + p0 = func_home[func] + n = len(used_by) + if n == 1: + p = list(used_by)[0] + p1 = func_home[p] + if p1 != p0: + func_home[func] = p1 + homes_changed = True + continue + elif n > 1: + phomes = set([]) + for p in used_by: + phomes.add(func_home[p]) + if len(phomes) == 1: + p1 = list(phomes)[0] + if p1 != p0: + func_home[func] = p1 + homes_changed = True + if not homes_changed: + break + +res_files = {} +for (func, h) in func_home.items(): + elems = res_files.get(h, set([])) + elems.add(func) + res_files[h] = elems + +print ("total files after amalgamation: %d" % len(res_files)) +#print_graph(res_files) + +outdir = os.path.join(dst_path, "new_clapack") +outdir_src = os.path.join(outdir, "src") +outdir_inc = os.path.join(outdir, "include") + +shutil.rmtree(outdir, ignore_errors=True) +try: + os.makedirs(outdir_src) +except os.error: + pass +try: + os.makedirs(outdir_inc) +except os.error: + pass + +f2c_appname = os.getenv("F2C", default="f2c") +print ("f2c used: %s" % f2c_appname) + +f2c_getver_cmd = f2c_appname + " -v" + +verstr = subprocess.check_output(f2c_getver_cmd.split(' ')).decode("utf-8") +if "for_lapack" not in verstr: + error("invalid version of f2c\n" + appdoc) + +f2c_flags = "-ctypes -localconst -no-proto" +f2c_cmd0 = f2c_appname + " " + f2c_flags +f2c_cmd1 = f2c_appname + " -hdr none " + f2c_flags + +lapack_protos = {} +extract_fn_regexp = re.compile(r'.+?(\w+)\s*\(') + +def extract_proto(func, csrc): + global lapack_protos + cname = func.lower() + "_" + cfname = func.lower() + ".c" + regexp_str = r'\n(?:/\* Subroutine \*/\s*)?\w+\s+\w+\s*\((?:.|\n)+?\)[\s\n]*\{' + proto_regexp = re.compile(regexp_str) + ps = proto_regexp.findall(csrc) + for p in ps: + n = p.find("*/") + if n < 0: + n = 0 + else: + n += 2 + p = p[n:-1].strip() + ";" + fns = extract_fn_regexp.findall(p) + if len(fns) != 1: + error("prototype of function (%s) when analyzing %s cannot be parsed" % (p, cfname)) + fn = fns[0] + if fn not in lapack_protos: + p = re.sub(r'\bcomplex\b', 'lapack_complex', p) + p = re.sub(r'\bdoublecomplex\b', 'lapack_doublecomplex', p) + lapack_protos[fn] = p + +for (filename, funcs) in sorted(res_files.items()): + out = "" + f2c_cmd = f2c_cmd0 + for func in sorted(list(funcs)): + ffilename = fun2file(func) + print ("running " + f2c_cmd + " on " + ffilename + " ...") + ffile = open(ffilename, 'rt') + delta_out = subprocess.check_output(f2c_cmd.split(' '), stdin=ffile).decode("utf-8") + # remove trailing whitespaces + delta_out = '\n'.join([l.rstrip() for l in delta_out.split('\n')]) + extract_proto(func, delta_out) + out += delta_out + ffile.close() + f2c_cmd = f2c_cmd1 + outname = os.path.join(outdir_src, filename.lower() + ".c") + outfile = open(outname, 'wt') + outfile.write(out) + outfile.close() + +proto_hdr = """// this is auto-generated header for Lapack subset +#ifndef __CLAPACK_H__ +#define __CLAPACK_H__ + +#include "cblas.h" + +#ifdef __cplusplus +extern "C" { +#endif + +%s + +#ifdef __cplusplus +} +#endif + +#endif +""" % "\n\n".join([p for (n, p) in sorted(lapack_protos.items())]) + +proto_hdr_fname = os.path.join(outdir_inc, "lapack.h") +f = open(proto_hdr_fname, 'wt') +f.write(proto_hdr) +f.close() diff --git a/3rdparty/clapack/runtime/cblas_wrap.c b/3rdparty/clapack/runtime/cblas_wrap.c new file mode 100644 index 0000000000..44b75551b1 --- /dev/null +++ b/3rdparty/clapack/runtime/cblas_wrap.c @@ -0,0 +1,289 @@ +#include "f2c.h" +#include + +void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc) +{ + char TA, TB; + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(layout, 2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA); + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(layout, 3, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); + return; + } + + cgemm_(&TA, &TB, (int*)&M, (int*)&N, (int*)&K, (complex*)alpha, (complex*)A, (int*)&lda, + (complex*)B, (int*)&ldb, (complex*)beta, (complex*)C, (int*)&ldc); + } + else if (layout == CblasRowMajor) + { + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(layout, 2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA); + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(layout, 2, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); + return; + } + + cgemm_(&TA, &TB, (int*)&N, (int*)&M, (int*)&K, (complex*)alpha, (complex*)B, (int*)&ldb, + (complex*)A, (int*)&lda, (complex*)beta, (complex*)C, (int*)&ldc); + } + else cblas_xerbla(layout, 1, "cblas_cgemm", "Illegal layout setting, %d\n", layout); +} + +void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const double alpha, const double *A, + const int lda, const double *B, const int ldb, + const double beta, double *C, const int ldc) +{ + char TA, TB; + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(layout, 2, "cblas_dgemm", "Illegal TransA setting, %d\n", TransA); + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(layout, 3, "cblas_dgemm", "Illegal TransB setting, %d\n", TransB); + return; + } + + dgemm_(&TA, &TB, (int*)&M, (int*)&N, (int*)&K, (double*)&alpha, (double*)A, (int*)&lda, + (double*)B, (int*)&ldb, (double*)&beta, (double*)C, (int*)&ldc); + } + else if (layout == CblasRowMajor) + { + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(layout, 2, "cblas_dgemm", "Illegal TransA setting, %d\n", TransA); + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(layout, 2, "cblas_dgemm", "Illegal TransB setting, %d\n", TransB); + return; + } + + dgemm_(&TA, &TB, (int*)&N, (int*)&M, (int*)&K, (double*)&alpha, (double*)B, (int*)&ldb, + (double*)A, (int*)&lda, (double*)&beta, (double*)C, (int*)&ldc); + } + else cblas_xerbla(layout, 1, "cblas_dgemm", "Illegal layout setting, %d\n", layout); +} + + +void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const float alpha, const float *A, + const int lda, const float *B, const int ldb, + const float beta, float *C, const int ldc) +{ + char TA, TB; + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(layout, 2, "cblas_sgemm", "Illegal TransA setting, %d\n", TransA); + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(layout, 3, "cblas_sgemm", "Illegal TransB setting, %d\n", TransB); + return; + } + + sgemm_(&TA, &TB, (int*)&M, (int*)&N, (int*)&K, (float*)&alpha, (float*)A, (int*)&lda, + (float*)B, (int*)&ldb, (float*)&beta, (float*)C, (int*)&ldc); + } + else if (layout == CblasRowMajor) + { + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(layout, 2, "cblas_sgemm", "Illegal TransA setting, %d\n", TransA); + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(layout, 2, "cblas_sgemm", "Illegal TransB setting, %d\n", TransB); + return; + } + + sgemm_(&TA, &TB, (int*)&N, (int*)&M, (int*)&K, (float*)&alpha, (float*)B, (int*)&ldb, + (float*)A, (int*)&lda, (float*)&beta, (float*)C, (int*)&ldc); + } + else cblas_xerbla(layout, 1, "cblas_sgemm", "Illegal layout setting, %d\n", layout); +} + +void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc) +{ + char TA, TB; + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(layout, 2, "cblas_zgemm", "Illegal TransA setting, %d\n", TransA); + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(layout, 3, "cblas_zgemm", "Illegal TransB setting, %d\n", TransB); + return; + } + + zgemm_(&TA, &TB, (int*)&M, (int*)&N, (int*)&K, (doublecomplex*)alpha, (doublecomplex*)A, (int*)&lda, + (doublecomplex*)B, (int*)&ldb, (doublecomplex*)beta, (doublecomplex*)C, (int*)&ldc); + } + else if (layout == CblasRowMajor) + { + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(layout, 2, "cblas_zgemm", "Illegal TransA setting, %d\n", TransA); + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(layout, 2, "cblas_zgemm", "Illegal TransB setting, %d\n", TransB); + return; + } + + zgemm_(&TA, &TB, (int*)&N, (int*)&M, (int*)&K, (doublecomplex*)alpha, (doublecomplex*)B, (int*)&ldb, + (doublecomplex*)A, (int*)&lda, (doublecomplex*)beta, (doublecomplex*)C, (int*)&ldc); + } + else cblas_xerbla(layout, 1, "cblas_zgemm", "Illegal layout setting, %d\n", layout); +} + +void cblas_xerbla(const CBLAS_LAYOUT layout, int info, const char *rout, const char *form, ...) +{ + extern int RowMajorStrg; + char empty[1] = ""; + va_list argptr; + + va_start(argptr, form); + + if (layout == CblasRowMajor) + { + if (strstr(rout,"gemm") != 0) + { + if (info == 5 ) info = 4; + else if (info == 4 ) info = 5; + else if (info == 11) info = 9; + else if (info == 9 ) info = 11; + } + else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0) + { + if (info == 5 ) info = 4; + else if (info == 4 ) info = 5; + } + else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0) + { + if (info == 7 ) info = 6; + else if (info == 6 ) info = 7; + } + else if (strstr(rout,"gemv") != 0) + { + if (info == 4) info = 3; + else if (info == 3) info = 4; + } + else if (strstr(rout,"gbmv") != 0) + { + if (info == 4) info = 3; + else if (info == 3) info = 4; + else if (info == 6) info = 5; + else if (info == 5) info = 6; + } + else if (strstr(rout,"ger") != 0) + { + if (info == 3) info = 2; + else if (info == 2) info = 3; + else if (info == 8) info = 6; + else if (info == 6) info = 8; + } + else if ( (strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0) + && strstr(rout,"her2k") == 0 ) + { + if (info == 8) info = 6; + else if (info == 6) info = 8; + } + } + if (info) + fprintf(stderr, "Parameter %d to routine %s was incorrect\n", info, rout); + vfprintf(stderr, form, argptr); + va_end(argptr); + if (info && !info) + xerbla_(empty, &info); /* Force link of our F77 error handler */ + exit(-1); +} diff --git a/3rdparty/clapack/runtime/dlamch_custom.c b/3rdparty/clapack/runtime/dlamch_custom.c new file mode 100644 index 0000000000..3168c49857 --- /dev/null +++ b/3rdparty/clapack/runtime/dlamch_custom.c @@ -0,0 +1,72 @@ +#include "f2c.h" +#include +#include + +/* *********************************************************************** */ + +double dlamc3_(double *a, double *b) +{ + /* -- 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 .. */ + + double 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 + +static const unsigned char lapack_dlamch_tab0[] = +{ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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 double lapack_dlamch_tab1[] = +{ + 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 +}; + +double dlamch_(char* cmach) +{ + return lapack_dlamch_tab1[lapack_dlamch_tab0[(unsigned char)cmach[0]]]; +} diff --git a/3rdparty/clapack/runtime/lapack_stubs.c b/3rdparty/clapack/runtime/lapack_stubs.c new file mode 100644 index 0000000000..25b54f34d2 --- /dev/null +++ b/3rdparty/clapack/runtime/lapack_stubs.c @@ -0,0 +1,96 @@ +#include "f2c.h" + +static const int CLAPACK_NOT_IMPLEMENTED = -1024; + +int sgesdd_(char *jobz, int *m, int *n, float *a, int *lda, + float *s, float *u, int *ldu, float *vt, int *ldvt, float *work, + int *lwork, int *iwork, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int dgels_(char *trans, int *m, int *n, int *nrhs, double *a, + int *lda, double *b, int *ldb, double *work, int *lwork, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int dgesv_(int *n, int *nrhs, double *a, int *lda, int *ipiv, + double *b, int *ldb, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int dgetrf_(int *m, int *n, double *a, int *lda, int *ipiv, + int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int dposv_(char *uplo, int *n, int *nrhs, double *a, int * + lda, double *b, int *ldb, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int dpotrf_(char *uplo, int *n, double *a, int *lda, int * + info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int sgels_(char *trans, int *m, int *n, int *nrhs, float *a, + int *lda, float *b, int *ldb, float *work, int *lwork, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int sgeev_(char *jobvl, char *jobvr, int *n, float *a, int * + lda, float *wr, float *wi, float *vl, int *ldvl, float *vr, int * + ldvr, float *work, int *lwork, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int sgeqrf_(int *m, int *n, float *a, int *lda, float *tau, + float *work, int *lwork, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int sgesv_(int *n, int *nrhs, float *a, int *lda, int *ipiv, + float *b, int *ldb, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int sgetrf_(int *m, int *n, float *a, int *lda, int *ipiv, + int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int sposv_(char *uplo, int *n, int *nrhs, float *a, int * + lda, float *b, int *ldb, int *info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} + +int spotrf_(char *uplo, int *n, float *a, int *lda, int * + info) +{ + *info = CLAPACK_NOT_IMPLEMENTED; + return 0; +} diff --git a/3rdparty/clapack/runtime/lsame_custom.c b/3rdparty/clapack/runtime/lsame_custom.c new file mode 100644 index 0000000000..e7866215aa --- /dev/null +++ b/3rdparty/clapack/runtime/lsame_custom.c @@ -0,0 +1,25 @@ +#include "f2c.h" + +static 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 +}; + +#define lapack_toupper(c) ((char)lapack_toupper_tab[(unsigned char)(c)]) + +int lsame_(char *ca, char *cb) +{ + return lapack_toupper(ca[0]) == lapack_toupper(cb[0]); +} diff --git a/3rdparty/clapack/runtime/pow_di.c b/3rdparty/clapack/runtime/pow_di.c new file mode 100644 index 0000000000..9ddf65e451 --- /dev/null +++ b/3rdparty/clapack/runtime/pow_di.c @@ -0,0 +1,27 @@ +#include "f2c.h" + +double pow_di(double *ap, int *bp) +{ + double p = 1; + double x = *ap; + int n = *bp; + + if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + unsigned u = (unsigned)n; + for(;;) + { + if((u & 1) != 0) + p *= x; + if((u >>= 1) == 0) + break; + x *= x; + } + } + return p; +} diff --git a/3rdparty/clapack/runtime/pow_ii.c b/3rdparty/clapack/runtime/pow_ii.c new file mode 100644 index 0000000000..2d1d21285f --- /dev/null +++ b/3rdparty/clapack/runtime/pow_ii.c @@ -0,0 +1,25 @@ +#include "f2c.h" + +int pow_ii(int *ap, int *bp) +{ + int p; + int x = *ap; + int n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + return x != -1 ? 0 : (n & 1) ? -1 : 1; + } + unsigned u = (unsigned)n; + for(p = 1; ; ) + { + if(u & 01) + p *= x; + if(u >>= 1) + x *= x; + else + break; + } + return p; +} diff --git a/3rdparty/clapack/runtime/s_cat.c b/3rdparty/clapack/runtime/s_cat.c new file mode 100644 index 0000000000..f0a422a971 --- /dev/null +++ b/3rdparty/clapack/runtime/s_cat.c @@ -0,0 +1,22 @@ +/* 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 "f2c.h" + +int s_cat(char *lp, char **rpp, int* rnp, int *np) +{ + int i, L = 0; + int n = *np; + + for(i = 0; i < n; i++) { + int ni = rnp[i]; + if(ni > 0) { + memcpy(lp + L, rpp[i], ni); + L += ni; + } + } + lp[L] = '\0'; + return 0; +} diff --git a/3rdparty/clapack/runtime/s_cmp.c b/3rdparty/clapack/runtime/s_cmp.c new file mode 100644 index 0000000000..5dbc89701d --- /dev/null +++ b/3rdparty/clapack/runtime/s_cmp.c @@ -0,0 +1,40 @@ +#include "f2c.h" + +/* compare two strings */ +int s_cmp(char *a0, char *b0) +{ + int la = (int)strlen(a0); + int lb = (int)strlen(b0); + unsigned char *a, *aend, *b, *bend; + a = (unsigned char *)a0; + b = (unsigned char *)b0; + aend = a + la; + bend = b + lb; + + if(la <= lb) + { + while(a < aend) + if(*a != *b) + return( *a - *b ); + else + { ++a; ++b; } + + while(b < bend) + if(*b != ' ') + return( ' ' - *b ); + else ++b; + } + else + { + while(b < bend) + if(*a == *b) + { ++a; ++b; } + else + return( *a - *b ); + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else ++a; + } + return(0); +} diff --git a/3rdparty/clapack/runtime/slamch_custom.c b/3rdparty/clapack/runtime/slamch_custom.c new file mode 100644 index 0000000000..df07228a62 --- /dev/null +++ b/3rdparty/clapack/runtime/slamch_custom.c @@ -0,0 +1,71 @@ +#include "f2c.h" +#include +#include + +/* *********************************************************************** */ + +double slamc3_(float *a, float *b) +{ + /* -- 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 .. */ + + float ret_val = *a + *b; + + return ret_val; + + /* End of SLAMC3 */ + +} /* slamc3_ */ + +/* simpler version of slamch 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 + +static const unsigned char lapack_slamch_tab0[] = +{ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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 double lapack_slamch_tab1[] = +{ + 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 +}; + +double slamch_(char* cmach) +{ + return lapack_slamch_tab1[lapack_slamch_tab0[(unsigned char)cmach[0]]]; +} diff --git a/3rdparty/clapack/runtime/xerbla_custom.c b/3rdparty/clapack/runtime/xerbla_custom.c new file mode 100644 index 0000000000..ce2fff50f4 --- /dev/null +++ b/3rdparty/clapack/runtime/xerbla_custom.c @@ -0,0 +1,19 @@ +/* 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 "f2c.h" + +/* Subroutine */ int xerbla_(char *srname, int *info) +{ + printf("** On entry to %s, parameter number %2i had an illegal value\n", srname, *info); + return 0; +} /* xerbla_ */ diff --git a/3rdparty/clapack/src/cgemm.c b/3rdparty/clapack/src/cgemm.c new file mode 100644 index 0000000000..a344e21b6f --- /dev/null +++ b/3rdparty/clapack/src/cgemm.c @@ -0,0 +1,752 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b CGEMM +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +// +// .. Scalar Arguments .. +// COMPLEX ALPHA,BETA +// INTEGER K,LDA,LDB,LDC,M,N +// CHARACTER TRANSA,TRANSB +// .. +// .. Array Arguments .. +// COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> CGEMM 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**T or op( X ) = X**H, +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] TRANSA +//> \verbatim +//> TRANSA is 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**T. +//> +//> TRANSA = 'C' or 'c', op( A ) = A**H. +//> \endverbatim +//> +//> \param[in] TRANSB +//> \verbatim +//> TRANSB is 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**T. +//> +//> TRANSB = 'C' or 'c', op( B ) = B**H. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is 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. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is 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. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is 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. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is COMPLEX +//> On entry, ALPHA specifies the scalar alpha. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is COMPLEX array, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is 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 ). +//> \endverbatim +//> +//> \param[in] B +//> \verbatim +//> B is COMPLEX array, 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. +//> \endverbatim +//> +//> \param[in] LDB +//> \verbatim +//> LDB is 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 ). +//> \endverbatim +//> +//> \param[in] BETA +//> \verbatim +//> BETA is COMPLEX +//> On entry, BETA specifies the scalar beta. When BETA is +//> supplied as zero then C need not be set on input. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is COMPLEX array, 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 ). +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is 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 ). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup complex_blas_level3 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int cgemm_(char *transa, char *transb, int *m, int *n, int * + k, complex *alpha, complex *a, int *lda, complex *b, int *ldb, + complex *beta, complex *c__, int *ldc) +{ + // Table of constant values + complex c_b1 = {1.f,0.f}; + complex c_b2 = {0.f,0.f}; + + // System generated locals + int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + complex q__1, q__2, q__3, q__4; + + // Local variables + int i__, j, l, info; + int nota, notb; + complex temp; + int conja, conjb; + int ncola; + extern int lsame_(char *, char *); + int nrowa, nrowb; + extern /* Subroutine */ int xerbla_(char *, int *); + + // + // -- Reference BLAS level3 routine (version 3.7.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Local Scalars .. + // .. + // .. Parameters .. + // .. + // + // Set NOTA and NOTB as true if A and B respectively are not + // conjugated or transposed, set CONJA and CONJB as true if A and + // B respectively are to be transposed but not conjugated 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"); + conja = lsame_(transa, "C"); + conjb = lsame_(transb, "C"); + 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 && ! conja && ! lsame_(transa, "T")) { + info = 1; + } else if (! notb && ! conjb && ! 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_("CGEMM ", &info); + return 0; + } + // + // Quick return if possible. + // + if (*m == 0 || *n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) + && (beta->r == 1.f && beta->i == 0.f)) { + return 0; + } + // + // And when alpha.eq.zero. + // + if (alpha->r == 0.f && alpha->i == 0.f) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 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__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + q__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +// 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->r == 0.f && beta->i == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +// L50: + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +// L60: + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +// L70: + } +// L80: + } +// L90: + } + } else if (conja) { + // + // Form C := alpha*A**H*B + beta*C. + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i, + q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +// L100: + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +// L110: + } +// L120: + } + } else { + // + // Form C := alpha*A**T*B + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +// L130: + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +// L140: + } +// L150: + } + } + } else if (nota) { + if (conjb) { + // + // Form C := alpha*A*B**H + beta*C. + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +// L160: + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +// L170: + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + r_cnjg(&q__2, &b[j + l * b_dim1]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +// L180: + } +// L190: + } +// L200: + } + } else { + // + // Form C := alpha*A*B**T + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +// L210: + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +// L220: + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +// L230: + } +// L240: + } +// L250: + } + } + } else if (conja) { + if (conjb) { + // + // Form C := alpha*A**H*B**H + beta*C. + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + r_cnjg(&q__4, &b[j + l * b_dim1]); + q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, q__2.i = + q__3.r * q__4.i + q__3.i * q__4.r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +// L260: + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +// L270: + } +// L280: + } + } else { + // + // Form C := alpha*A**H*B**T + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + i__4 = j + l * b_dim1; + q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i, + q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +// L290: + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +// L300: + } +// L310: + } + } + } else { + if (conjb) { + // + // Form C := alpha*A**T*B**H + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + r_cnjg(&q__3, &b[j + l * b_dim1]); + q__2.r = a[i__4].r * q__3.r - a[i__4].i * q__3.i, + q__2.i = a[i__4].r * q__3.i + a[i__4].i * + q__3.r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +// L320: + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +// L330: + } +// L340: + } + } else { + // + // Form C := alpha*A**T*B**T + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = j + l * b_dim1; + q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +// L350: + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +// L360: + } +// L370: + } + } + } + return 0; + // + // End of CGEMM . + // +} // cgemm_ + diff --git a/3rdparty/clapack/src/dcopy.c b/3rdparty/clapack/src/dcopy.c new file mode 100644 index 0000000000..0be80d373d --- /dev/null +++ b/3rdparty/clapack/src/dcopy.c @@ -0,0 +1,171 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DCOPY +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +// +// .. Scalar Arguments .. +// INTEGER INCX,INCY,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION DX(*),DY(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DCOPY copies a vector, x, to a vector, y. +//> uses unrolled loops for increments equal to 1. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> number of elements in input vector(s) +//> \endverbatim +//> +//> \param[in] DX +//> \verbatim +//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> storage spacing between elements of DX +//> \endverbatim +//> +//> \param[out] DY +//> \verbatim +//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +//> \endverbatim +//> +//> \param[in] INCY +//> \verbatim +//> INCY is INTEGER +//> storage spacing between elements of DY +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup double_blas_level1 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> jack dongarra, linpack, 3/11/78. +//> modified 12/3/93, array(1) declarations changed to array(*) +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dcopy_(int *n, double *dx, int *incx, double *dy, int * + incy) +{ + // System generated locals + int i__1; + + // Local variables + int i__, m, ix, iy, mp1; + + // + // -- Reference BLAS level1 routine (version 3.8.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Local Scalars .. + // .. + // .. Intrinsic Functions .. + // .. + // Parameter adjustments + --dy; + --dx; + + // Function Body + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + // + // code for both increments equal to 1 + // + // + // clean-up loop + // + m = *n % 7; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] = dx[i__]; + } + if (*n < 7) { + return 0; + } + } + 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]; + } + } else { + // + // 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; + } + } + return 0; +} // dcopy_ + diff --git a/3rdparty/clapack/src/ddot.c b/3rdparty/clapack/src/ddot.c new file mode 100644 index 0000000000..d95ad2306d --- /dev/null +++ b/3rdparty/clapack/src/ddot.c @@ -0,0 +1,172 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DDOT +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +// +// .. Scalar Arguments .. +// INTEGER INCX,INCY,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION DX(*),DY(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DDOT forms the dot product of two vectors. +//> uses unrolled loops for increments equal to one. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> number of elements in input vector(s) +//> \endverbatim +//> +//> \param[in] DX +//> \verbatim +//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> storage spacing between elements of DX +//> \endverbatim +//> +//> \param[in] DY +//> \verbatim +//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +//> \endverbatim +//> +//> \param[in] INCY +//> \verbatim +//> INCY is INTEGER +//> storage spacing between elements of DY +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup double_blas_level1 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> jack dongarra, linpack, 3/11/78. +//> modified 12/3/93, array(1) declarations changed to array(*) +//> \endverbatim +//> +// ===================================================================== +double ddot_(int *n, double *dx, int *incx, double *dy, int *incy) +{ + // System generated locals + int i__1; + double ret_val; + + // Local variables + int i__, m, ix, iy, mp1; + double dtemp; + + // + // -- Reference BLAS level1 routine (version 3.8.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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) { + // + // code for both increments equal to 1 + // + // + // clean-up loop + // + m = *n % 5; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += dx[i__] * dy[i__]; + } + if (*n < 5) { + ret_val = dtemp; + return ret_val; + } + } + 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]; + } + } else { + // + // 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; + } + } + ret_val = dtemp; + return ret_val; +} // ddot_ + diff --git a/3rdparty/clapack/src/dgeev.c b/3rdparty/clapack/src/dgeev.c new file mode 100644 index 0000000000..a912ba93d1 --- /dev/null +++ b/3rdparty/clapack/src/dgeev.c @@ -0,0 +1,14369 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DAXPY +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION DA +// INTEGER INCX,INCY,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION DX(*),DY(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DAXPY constant times a vector plus a vector. +//> uses unrolled loops for increments equal to one. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> number of elements in input vector(s) +//> \endverbatim +//> +//> \param[in] DA +//> \verbatim +//> DA is DOUBLE PRECISION +//> On entry, DA specifies the scalar alpha. +//> \endverbatim +//> +//> \param[in] DX +//> \verbatim +//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> storage spacing between elements of DX +//> \endverbatim +//> +//> \param[in,out] DY +//> \verbatim +//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +//> \endverbatim +//> +//> \param[in] INCY +//> \verbatim +//> INCY is INTEGER +//> storage spacing between elements of DY +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup double_blas_level1 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> jack dongarra, linpack, 3/11/78. +//> modified 12/3/93, array(1) declarations changed to array(*) +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int daxpy_(int *n, double *da, double *dx, int *incx, double + *dy, int *incy) +{ + // System generated locals + int i__1; + + // Local variables + int i__, m, ix, iy, mp1; + + // + // -- Reference BLAS level1 routine (version 3.8.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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) { + // + // code for both increments equal to 1 + // + // + // clean-up loop + // + m = *n % 4; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] += *da * dx[i__]; + } + } + if (*n < 4) { + return 0; + } + 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]; + } + } else { + // + // 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; + } + } + return 0; +} // daxpy_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGEBAK +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEBAK + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, +// INFO ) +// +// .. Scalar Arguments .. +// CHARACTER JOB, SIDE +// INTEGER IHI, ILO, INFO, LDV, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION SCALE( * ), V( LDV, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEBAK forms the right or left eigenvectors of a real general matrix +//> by backward transformation on the computed eigenvectors of the +//> balanced matrix output by DGEBAL. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] JOB +//> \verbatim +//> JOB is CHARACTER*1 +//> Specifies the type of backward transformation required: +//> = 'N': do nothing, return immediately; +//> = 'P': do backward transformation for permutation only; +//> = 'S': do backward transformation for scaling only; +//> = 'B': do backward transformations for both permutation and +//> scaling. +//> JOB must be the same as the argument JOB supplied to DGEBAL. +//> \endverbatim +//> +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'R': V contains right eigenvectors; +//> = 'L': V contains left eigenvectors. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of rows of the matrix V. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> The integers ILO and IHI determined by DGEBAL. +//> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +//> \endverbatim +//> +//> \param[in] SCALE +//> \verbatim +//> SCALE is DOUBLE PRECISION array, dimension (N) +//> Details of the permutation and scaling factors, as returned +//> by DGEBAL. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of columns of the matrix V. M >= 0. +//> \endverbatim +//> +//> \param[in,out] V +//> \verbatim +//> V is DOUBLE PRECISION array, dimension (LDV,M) +//> On entry, the matrix of right or left eigenvectors to be +//> transformed, as returned by DHSEIN or DTREVC. +//> On exit, V is overwritten by the transformed eigenvectors. +//> \endverbatim +//> +//> \param[in] LDV +//> \verbatim +//> LDV is INTEGER +//> The leading dimension of the array V. LDV >= max(1,N). +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleGEcomputational +// +// ===================================================================== +/* Subroutine */ int dgebak_(char *job, char *side, int *n, int *ilo, int * + ihi, double *scale, int *m, double *v, int *ldv, int *info) +{ + // System generated locals + int v_dim1, v_offset, i__1; + + // Local variables + int i__, k; + double s; + int ii; + extern /* Subroutine */ int dscal_(int *, double *, double *, int *); + extern int lsame_(char *, char *); + extern /* Subroutine */ int dswap_(int *, double *, int *, double *, int * + ); + int leftv; + extern /* Subroutine */ int xerbla_(char *, int *); + int rightv; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Decode and Test the input parameters + // + // Parameter adjustments + --scale; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + + // Function Body + rightv = lsame_(side, "R"); + leftv = lsame_(side, "L"); + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") && ! + lsame_(job, "B")) { + *info = -1; + } else if (! rightv && ! leftv) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1 || *ilo > max(1,*n)) { + *info = -4; + } else if (*ihi < min(*ilo,*n) || *ihi > *n) { + *info = -5; + } else if (*m < 0) { + *info = -7; + } else if (*ldv < max(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEBAK", &i__1); + return 0; + } + // + // Quick return if possible + // + if (*n == 0) { + return 0; + } + if (*m == 0) { + return 0; + } + if (lsame_(job, "N")) { + return 0; + } + if (*ilo == *ihi) { + goto L30; + } + // + // Backward balance + // + if (lsame_(job, "S") || lsame_(job, "B")) { + if (rightv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + s = scale[i__]; + dscal_(m, &s, &v[i__ + v_dim1], ldv); +// L10: + } + } + if (leftv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + s = 1. / scale[i__]; + dscal_(m, &s, &v[i__ + v_dim1], ldv); +// L20: + } + } + } + // + // Backward permutation + // + // For I = ILO-1 step -1 until 1, + // IHI+1 step 1 until N do -- + // +L30: + if (lsame_(job, "P") || lsame_(job, "B")) { + if (rightv) { + i__1 = *n; + for (ii = 1; ii <= i__1; ++ii) { + i__ = ii; + if (i__ >= *ilo && i__ <= *ihi) { + goto L40; + } + if (i__ < *ilo) { + i__ = *ilo - ii; + } + k = (int) scale[i__]; + if (k == i__) { + goto L40; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L40: + ; + } + } + if (leftv) { + i__1 = *n; + for (ii = 1; ii <= i__1; ++ii) { + i__ = ii; + if (i__ >= *ilo && i__ <= *ihi) { + goto L50; + } + if (i__ < *ilo) { + i__ = *ilo - ii; + } + k = (int) scale[i__]; + if (k == i__) { + goto L50; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L50: + ; + } + } + } + return 0; + // + // End of DGEBAK + // +} // dgebak_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGEBAL +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEBAL + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER JOB +// INTEGER IHI, ILO, INFO, LDA, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), SCALE( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEBAL balances a general real matrix A. This involves, first, +//> permuting A by a similarity transformation to isolate eigenvalues +//> in the first 1 to ILO-1 and last IHI+1 to N elements on the +//> diagonal; and second, applying a diagonal similarity transformation +//> to rows and columns ILO to IHI to make the rows and columns as +//> close in norm as possible. Both steps are optional. +//> +//> Balancing may reduce the 1-norm of the matrix, and improve the +//> accuracy of the computed eigenvalues and/or eigenvectors. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] JOB +//> \verbatim +//> JOB is CHARACTER*1 +//> Specifies the operations to be performed on A: +//> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 +//> for i = 1,...,N; +//> = 'P': permute only; +//> = 'S': scale only; +//> = 'B': both permute and scale. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> On entry, the input matrix A. +//> On exit, A is overwritten by the balanced matrix. +//> If JOB = 'N', A is not referenced. +//> See Further Details. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,N). +//> \endverbatim +//> +//> \param[out] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> \param[out] IHI +//> \verbatim +//> IHI is INTEGER +//> ILO and IHI are set to integers such that on exit +//> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. +//> If JOB = 'N' or 'S', ILO = 1 and IHI = N. +//> \endverbatim +//> +//> \param[out] SCALE +//> \verbatim +//> SCALE is DOUBLE PRECISION array, dimension (N) +//> Details of the permutations and scaling factors applied to +//> A. If P(j) is the index of the row and column interchanged +//> with row and column j and D(j) is the scaling factor +//> applied to row and column j, then +//> SCALE(j) = P(j) for j = 1,...,ILO-1 +//> = D(j) for j = ILO,...,IHI +//> = P(j) for j = IHI+1,...,N. +//> The order in which the interchanges are made is N to IHI+1, +//> then 1 to ILO-1. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> The permutations consist of row and column interchanges which put +//> the matrix in the form +//> +//> ( T1 X Y ) +//> P A P = ( 0 B Z ) +//> ( 0 0 T2 ) +//> +//> where T1 and T2 are upper triangular matrices whose eigenvalues lie +//> along the diagonal. The column indices ILO and IHI mark the starting +//> and ending columns of the submatrix B. Balancing consists of applying +//> a diagonal similarity transformation inv(D) * B * D to make the +//> 1-norms of each row of B and its corresponding column nearly equal. +//> The output matrix is +//> +//> ( T1 X*D Y ) +//> ( 0 inv(D)*B*D inv(D)*Z ). +//> ( 0 0 T2 ) +//> +//> Information about the permutations P and the diagonal matrix D is +//> returned in the vector SCALE. +//> +//> This subroutine is based on the EISPACK routine BALANC. +//> +//> Modified by Tzu-Yi Chen, Computer Science Division, University of +//> California at Berkeley, USA +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgebal_(char *job, int *n, double *a, int *lda, int *ilo, + int *ihi, double *scale, int *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int a_dim1, a_offset, i__1, i__2; + double d__1, d__2; + + // Local variables + double c__, f, g; + int i__, j, k, l, m; + double r__, s, ca, ra; + int ica, ira, iexc; + extern double dnrm2_(int *, double *, int *); + extern /* Subroutine */ int dscal_(int *, double *, double *, int *); + extern int lsame_(char *, char *); + extern /* Subroutine */ int dswap_(int *, double *, int *, double *, int * + ); + double sfmin1, sfmin2, sfmax1, sfmax2; + extern double dlamch_(char *); + extern int idamax_(int *, double *, int *); + extern int disnan_(double *); + extern /* Subroutine */ int xerbla_(char *, int *); + int noconv; + + // + // -- LAPACK computational routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + --scale; + + // Function Body + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") && ! + lsame_(job, "B")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < max(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEBAL", &i__1); + return 0; + } + k = 1; + l = *n; + if (*n == 0) { + goto L210; + } + if (lsame_(job, "N")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scale[i__] = 1.; +// L10: + } + goto L210; + } + if (lsame_(job, "S")) { + goto L120; + } + // + // Permutation to isolate eigenvalues if possible + // + goto L50; + // + // Row and column exchange. + // +L20: + scale[m] = (double) j; + if (j == m) { + goto L30; + } + dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1); + i__1 = *n - k + 1; + dswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda); +L30: + switch (iexc) { + case 1: goto L40; + case 2: goto L80; + } + // + // Search for rows isolating an eigenvalue and push them down. + // +L40: + if (l == 1) { + goto L210; + } + --l; +L50: + for (j = l; j >= 1; --j) { + i__1 = l; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ == j) { + goto L60; + } + if (a[j + i__ * a_dim1] != 0.) { + goto L70; + } +L60: + ; + } + m = l; + iexc = 1; + goto L20; +L70: + ; + } + goto L90; + // + // Search for columns isolating an eigenvalue and push them left. + // +L80: + ++k; +L90: + i__1 = l; + for (j = k; j <= i__1; ++j) { + i__2 = l; + for (i__ = k; i__ <= i__2; ++i__) { + if (i__ == j) { + goto L100; + } + if (a[i__ + j * a_dim1] != 0.) { + goto L110; + } +L100: + ; + } + m = k; + iexc = 2; + goto L20; +L110: + ; + } +L120: + i__1 = l; + for (i__ = k; i__ <= i__1; ++i__) { + scale[i__] = 1.; +// L130: + } + if (lsame_(job, "P")) { + goto L210; + } + // + // Balance the submatrix in rows K to L. + // + // Iterative loop for norm reduction + // + sfmin1 = dlamch_("S") / dlamch_("P"); + sfmax1 = 1. / sfmin1; + sfmin2 = sfmin1 * 2.; + sfmax2 = 1. / sfmin2; +L140: + noconv = FALSE_; + i__1 = l; + for (i__ = k; i__ <= i__1; ++i__) { + i__2 = l - k + 1; + c__ = dnrm2_(&i__2, &a[k + i__ * a_dim1], &c__1); + i__2 = l - k + 1; + r__ = dnrm2_(&i__2, &a[i__ + k * a_dim1], lda); + ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1); + ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1)); + i__2 = *n - k + 1; + ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda); + ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1)); + // + // Guard against zero C or R due to underflow. + // + if (c__ == 0. || r__ == 0.) { + goto L200; + } + g = r__ / 2.; + f = 1.; + s = c__ + r__; +L160: + // Computing MAX + d__1 = max(f,c__); + // Computing MIN + d__2 = min(r__,g); + if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) { + goto L170; + } + d__1 = c__ + f + ca + r__ + g + ra; + if (disnan_(&d__1)) { + // + // Exit if NaN to avoid infinite loop + // + *info = -3; + i__2 = -(*info); + xerbla_("DGEBAL", &i__2); + return 0; + } + f *= 2.; + c__ *= 2.; + ca *= 2.; + r__ /= 2.; + g /= 2.; + ra /= 2.; + goto L160; +L170: + g = c__ / 2.; +L180: + // Computing MIN + d__1 = min(f,c__), d__1 = min(d__1,g); + if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) { + goto L190; + } + f /= 2.; + c__ /= 2.; + g /= 2.; + ca /= 2.; + r__ *= 2.; + ra *= 2.; + goto L180; + // + // Now balance. + // +L190: + if (c__ + r__ >= s * .95) { + goto L200; + } + if (f < 1. && scale[i__] < 1.) { + if (f * scale[i__] <= sfmin1) { + goto L200; + } + } + if (f > 1. && scale[i__] > 1.) { + if (scale[i__] >= sfmax1 / f) { + goto L200; + } + } + g = 1. / f; + scale[i__] *= f; + noconv = TRUE_; + i__2 = *n - k + 1; + dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda); + dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1); +L200: + ; + } + if (noconv) { + goto L140; + } +L210: + *ilo = k; + *ihi = l; + return 0; + // + // End of DGEBAL + // +} // dgebal_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief DGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEEV + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, +// LDVR, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER JOBVL, JOBVR +// INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), +// $ WI( * ), WORK( * ), WR( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEEV computes for an N-by-N real nonsymmetric matrix A, the +//> eigenvalues and, optionally, the left and/or right eigenvectors. +//> +//> The right eigenvector v(j) of A satisfies +//> A * v(j) = lambda(j) * v(j) +//> where lambda(j) is its eigenvalue. +//> The left eigenvector u(j) of A satisfies +//> u(j)**H * A = lambda(j) * u(j)**H +//> where u(j)**H denotes the conjugate-transpose of u(j). +//> +//> The computed eigenvectors are normalized to have Euclidean norm +//> equal to 1 and largest component real. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] JOBVL +//> \verbatim +//> JOBVL is CHARACTER*1 +//> = 'N': left eigenvectors of A are not computed; +//> = 'V': left eigenvectors of A are computed. +//> \endverbatim +//> +//> \param[in] JOBVR +//> \verbatim +//> JOBVR is CHARACTER*1 +//> = 'N': right eigenvectors of A are not computed; +//> = 'V': right eigenvectors of A are computed. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> On entry, the N-by-N matrix A. +//> On exit, A has been overwritten. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,N). +//> \endverbatim +//> +//> \param[out] WR +//> \verbatim +//> WR is DOUBLE PRECISION array, dimension (N) +//> \endverbatim +//> +//> \param[out] WI +//> \verbatim +//> WI is DOUBLE PRECISION array, dimension (N) +//> WR and WI contain the real and imaginary parts, +//> respectively, of the computed eigenvalues. Complex +//> conjugate pairs of eigenvalues appear consecutively +//> with the eigenvalue having the positive imaginary part +//> first. +//> \endverbatim +//> +//> \param[out] VL +//> \verbatim +//> VL is DOUBLE PRECISION array, dimension (LDVL,N) +//> If JOBVL = 'V', the left eigenvectors u(j) are stored one +//> after another in the columns of VL, in the same order +//> as their eigenvalues. +//> If JOBVL = 'N', VL is not referenced. +//> If the j-th eigenvalue is real, then u(j) = VL(:,j), +//> the j-th column of VL. +//> If the j-th and (j+1)-st eigenvalues form a complex +//> conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and +//> u(j+1) = VL(:,j) - i*VL(:,j+1). +//> \endverbatim +//> +//> \param[in] LDVL +//> \verbatim +//> LDVL is INTEGER +//> The leading dimension of the array VL. LDVL >= 1; if +//> JOBVL = 'V', LDVL >= N. +//> \endverbatim +//> +//> \param[out] VR +//> \verbatim +//> VR is DOUBLE PRECISION array, dimension (LDVR,N) +//> If JOBVR = 'V', the right eigenvectors v(j) are stored one +//> after another in the columns of VR, in the same order +//> as their eigenvalues. +//> If JOBVR = 'N', VR is not referenced. +//> If the j-th eigenvalue is real, then v(j) = VR(:,j), +//> the j-th column of VR. +//> If the j-th and (j+1)-st eigenvalues form a complex +//> conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and +//> v(j+1) = VR(:,j) - i*VR(:,j+1). +//> \endverbatim +//> +//> \param[in] LDVR +//> \verbatim +//> LDVR is INTEGER +//> The leading dimension of the array VR. LDVR >= 1; if +//> JOBVR = 'V', LDVR >= N. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the array WORK. LWORK >= max(1,3*N), and +//> if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good +//> performance, LWORK must 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: if INFO = i, the QR algorithm failed to compute all the +//> eigenvalues, and no eigenvectors have been computed; +//> elements i+1:N of WR and WI contain eigenvalues which +//> have converged. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +// @precisions fortran d -> s +// +//> \ingroup doubleGEeigen +// +// ===================================================================== +/* Subroutine */ int dgeev_(char *jobvl, char *jobvr, int *n, double *a, int * + lda, double *wr, double *wi, double *vl, int *ldvl, double *vr, int * + ldvr, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c__0 = 0; + int c_n1 = -1; + + // System generated locals + int a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, + i__3; + double d__1, d__2; + + // Local variables + int i__, k; + double r__, cs, sn; + int ihi; + double scl; + int ilo; + double dum[1], eps; + int lwork_trevc__, ibal; + char side[1+1]={'\0'}; + double anrm; + int ierr, itau; + extern /* Subroutine */ int drot_(int *, double *, int *, double *, int *, + double *, double *); + int iwrk, nout; + extern double dnrm2_(int *, double *, int *); + extern /* Subroutine */ int dscal_(int *, double *, double *, int *); + extern int lsame_(char *, char *); + extern double dlapy2_(double *, double *); + extern /* Subroutine */ int dlabad_(double *, double *), dgebak_(char *, + char *, int *, int *, int *, double *, int *, double *, int *, + int *), dgebal_(char *, int *, double *, int *, int *, int *, + double *, int *); + int scalea; + extern double dlamch_(char *); + double cscale; + extern double dlange_(char *, int *, int *, double *, int *, double *); + extern /* Subroutine */ int dgehrd_(int *, int *, int *, double *, int *, + double *, double *, int *, int *), dlascl_(char *, int *, int *, + double *, double *, int *, int *, double *, int *, int *); + extern int idamax_(int *, double *, int *); + extern /* Subroutine */ int dlacpy_(char *, int *, int *, double *, int *, + double *, int *), dlartg_(double *, double *, double *, double *, + double *), xerbla_(char *, int *); + int select[1]; + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + double bignum; + extern /* Subroutine */ int dorghr_(int *, int *, int *, double *, int *, + double *, double *, int *, int *), dhseqr_(char *, char *, int *, + int *, int *, double *, int *, double *, double *, double *, int * + , double *, int *, int *); + int minwrk, maxwrk; + int wantvl; + double smlnum; + int hswork; + int lquery, wantvr; + extern /* Subroutine */ int dtrevc3_(char *, char *, int *, int *, double + *, int *, double *, int *, double *, int *, int *, int *, double * + , int *, int *); + + // + // -- LAPACK driver routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + --wr; + --wi; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --work; + + // Function Body + *info = 0; + lquery = *lwork == -1; + wantvl = lsame_(jobvl, "V"); + wantvr = lsame_(jobvr, "V"); + if (! wantvl && ! lsame_(jobvl, "N")) { + *info = -1; + } else if (! wantvr && ! lsame_(jobvr, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < max(1,*n)) { + *info = -5; + } else if (*ldvl < 1 || wantvl && *ldvl < *n) { + *info = -9; + } else if (*ldvr < 1 || wantvr && *ldvr < *n) { + *info = -11; + } + // + // 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. + // HSWORK refers to the workspace preferred by DHSEQR, as + // calculated below. HSWORK is computed assuming ILO=1 and IHI=N, + // the worst case.) + // + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, + n, &c__0); + if (wantvl) { + minwrk = *n << 2; + // Computing MAX + i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, + "DORGHR", " ", n, &c__1, n, &c_n1); + maxwrk = max(i__1,i__2); + dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ + 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info); + hswork = (int) work[1]; + // Computing MAX + i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = * + n + hswork; + maxwrk = max(i__1,i__2); + dtrevc3_("L", "B", select, n, &a[a_offset], lda, &vl[ + vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, & + work[1], &c_n1, &ierr); + lwork_trevc__ = (int) work[1]; + // Computing MAX + i__1 = maxwrk, i__2 = *n + lwork_trevc__; + maxwrk = max(i__1,i__2); + // Computing MAX + i__1 = maxwrk, i__2 = *n << 2; + maxwrk = max(i__1,i__2); + } else if (wantvr) { + minwrk = *n << 2; + // Computing MAX + i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, + "DORGHR", " ", n, &c__1, n, &c_n1); + maxwrk = max(i__1,i__2); + dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ + 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); + hswork = (int) work[1]; + // Computing MAX + i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = * + n + hswork; + maxwrk = max(i__1,i__2); + dtrevc3_("R", "B", select, n, &a[a_offset], lda, &vl[ + vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, & + work[1], &c_n1, &ierr); + lwork_trevc__ = (int) work[1]; + // Computing MAX + i__1 = maxwrk, i__2 = *n + lwork_trevc__; + maxwrk = max(i__1,i__2); + // Computing MAX + i__1 = maxwrk, i__2 = *n << 2; + maxwrk = max(i__1,i__2); + } else { + minwrk = *n * 3; + dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ + 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); + hswork = (int) work[1]; + // Computing MAX + i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = * + n + hswork; + maxwrk = max(i__1,i__2); + } + maxwrk = max(maxwrk,minwrk); + } + work[1] = (double) maxwrk; + if (*lwork < minwrk && ! lquery) { + *info = -13; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEEV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + // + // Quick return if possible + // + if (*n == 0) { + return 0; + } + // + // Get machine constants + // + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + // + // Scale A if max element outside range [SMLNUM,BIGNUM] + // + anrm = dlange_("M", n, n, &a[a_offset], lda, dum); + scalea = FALSE_; + if (anrm > 0. && anrm < smlnum) { + scalea = TRUE_; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = TRUE_; + cscale = bignum; + } + if (scalea) { + dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + // + // Balance the matrix + // (Workspace: need N) + // + ibal = 1; + dgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr); + // + // Reduce to upper Hessenberg form + // (Workspace: need 3*N, prefer 2*N+N*NB) + // + itau = ibal + *n; + iwrk = itau + *n; + i__1 = *lwork - iwrk + 1; + dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, + &ierr); + if (wantvl) { + // + // Want left eigenvectors + // Copy Householder vectors to VL + // + *(unsigned char *)side = 'L'; + dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl); + // + // Generate orthogonal matrix in VL + // (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) + // + i__1 = *lwork - iwrk + 1; + dorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], + &i__1, &ierr); + // + // Perform QR iteration, accumulating Schur vectors in VL + // (Workspace: need N+1, prefer N+HSWORK (see comments) ) + // + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & + vl[vl_offset], ldvl, &work[iwrk], &i__1, info); + if (wantvr) { + // + // Want left and right eigenvectors + // Copy Schur vectors to VR + // + *(unsigned char *)side = 'B'; + dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); + } + } else if (wantvr) { + // + // Want right eigenvectors + // Copy Householder vectors to VR + // + *(unsigned char *)side = 'R'; + dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr); + // + // Generate orthogonal matrix in VR + // (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) + // + i__1 = *lwork - iwrk + 1; + dorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], + &i__1, &ierr); + // + // Perform QR iteration, accumulating Schur vectors in VR + // (Workspace: need N+1, prefer N+HSWORK (see comments) ) + // + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & + vr[vr_offset], ldvr, &work[iwrk], &i__1, info); + } else { + // + // Compute eigenvalues only + // (Workspace: need N+1, prefer N+HSWORK (see comments) ) + // + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & + vr[vr_offset], ldvr, &work[iwrk], &i__1, info); + } + // + // If INFO .NE. 0 from DHSEQR, then quit + // + if (*info != 0) { + goto L50; + } + if (wantvl || wantvr) { + // + // Compute left and/or right eigenvectors + // (Workspace: need 4*N, prefer N + N + 2*N*NB) + // + i__1 = *lwork - iwrk + 1; + dtrevc3_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &i__1, & + ierr); + } + if (wantvl) { + // + // Undo balancing of left eigenvectors + // (Workspace: need N) + // + dgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl, + &ierr); + // + // Normalize left eigenvectors and make largest component real + // + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (wi[i__] == 0.) { + scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); + dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); + } else if (wi[i__] > 0.) { + d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); + scl = 1. / dlapy2_(&d__1, &d__2); + dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); + dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + // Computing 2nd power + d__1 = vl[k + i__ * vl_dim1]; + // Computing 2nd power + d__2 = vl[k + (i__ + 1) * vl_dim1]; + work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2; +// L10: + } + k = idamax_(n, &work[iwrk], &c__1); + dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1], + &cs, &sn, &r__); + drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) * + vl_dim1 + 1], &c__1, &cs, &sn); + vl[k + (i__ + 1) * vl_dim1] = 0.; + } +// L20: + } + } + if (wantvr) { + // + // Undo balancing of right eigenvectors + // (Workspace: need N) + // + dgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr, + &ierr); + // + // Normalize right eigenvectors and make largest component real + // + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (wi[i__] == 0.) { + scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); + dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); + } else if (wi[i__] > 0.) { + d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); + scl = 1. / dlapy2_(&d__1, &d__2); + dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); + dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + // Computing 2nd power + d__1 = vr[k + i__ * vr_dim1]; + // Computing 2nd power + d__2 = vr[k + (i__ + 1) * vr_dim1]; + work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2; +// L30: + } + k = idamax_(n, &work[iwrk], &c__1); + dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1], + &cs, &sn, &r__); + drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) * + vr_dim1 + 1], &c__1, &cs, &sn); + vr[k + (i__ + 1) * vr_dim1] = 0.; + } +// L40: + } + } + // + // Undo scaling if necessary + // +L50: + if (scalea) { + i__1 = *n - *info; + // Computing MAX + i__3 = *n - *info; + i__2 = max(i__3,1); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info + + 1], &i__2, &ierr); + i__1 = *n - *info; + // Computing MAX + i__3 = *n - *info; + i__2 = max(i__3,1); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info + + 1], &i__2, &ierr); + if (*info > 0) { + i__1 = ilo - 1; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1], + n, &ierr); + i__1 = ilo - 1; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1], + n, &ierr); + } + } + work[1] = (double) maxwrk; + return 0; + // + // End of DGEEV + // +} // dgeev_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEHD2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER IHI, ILO, INFO, LDA, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEHD2 reduces a real general matrix A to upper Hessenberg form H by +//> an orthogonal similarity transformation: Q**T * A * Q = H . +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> +//> It is assumed that A is already upper triangular in rows +//> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +//> set by a previous call to DGEBAL; otherwise they should be +//> set to 1 and N respectively. See Further Details. +//> 1 <= ILO <= IHI <= max(1,N). +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> On entry, the n by n general matrix to be reduced. +//> On exit, the upper triangle and the first subdiagonal of A +//> are overwritten with the upper Hessenberg matrix H, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,N). +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (N-1) +//> The scalar factors of the elementary reflectors (see Further +//> Details). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (N) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> The matrix Q is represented as a product of (ihi-ilo) elementary +//> reflectors +//> +//> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +//> +//> Each H(i) has the form +//> +//> H(i) = I - tau * v * v**T +//> +//> where tau is a real scalar, and v is a real vector with +//> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +//> exit in A(i+2:ihi,i), and tau in TAU(i). +//> +//> The contents of A are illustrated by the following example, with +//> n = 7, ilo = 2 and ihi = 6: +//> +//> on entry, on exit, +//> +//> ( a a a a a a a ) ( a a h h h h a ) +//> ( a a a a a a ) ( a h h h h a ) +//> ( a a a a a a ) ( h h h h h h ) +//> ( a a a a a a ) ( v2 h h h h h ) +//> ( a a a a a a ) ( v2 v3 h h h h ) +//> ( a a a a a a ) ( v2 v3 v4 h h h ) +//> ( a ) ( a ) +//> +//> where a denotes an element of the original matrix A, h denotes a +//> modified element of the upper Hessenberg matrix H, and vi denotes an +//> element of the vector defining H(i). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgehd2_(int *n, int *ilo, int *ihi, double *a, int *lda, + double *tau, double *work, int *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3; + + // Local variables + int i__; + double aii; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *), dlarfg_(int *, double *, + double *, int *, double *), xerbla_(char *, int *); + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + --tau; + --work; + + // Function Body + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > max(1,*n)) { + *info = -2; + } else if (*ihi < min(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < max(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEHD2", &i__1); + return 0; + } + i__1 = *ihi - 1; + for (i__ = *ilo; i__ <= i__1; ++i__) { + // + // Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) + // + i__2 = *ihi - 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__]); + aii = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; + // + // Apply H(i) to A(1:ihi,i+1:ihi) from the right + // + i__2 = *ihi - i__; + dlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]); + // + // Apply H(i) to A(i+1:ihi,i+1:n) from the left + // + i__2 = *ihi - i__; + i__3 = *n - i__; + dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]); + a[i__ + 1 + i__ * a_dim1] = aii; +// L10: + } + return 0; + // + // End of DGEHD2 + // +} // dgehd2_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGEHRD +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEHRD + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER IHI, ILO, INFO, LDA, LWORK, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEHRD reduces a real general matrix A to upper Hessenberg form H by +//> an orthogonal similarity transformation: Q**T * A * Q = H . +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> +//> It is assumed that A is already upper triangular in rows +//> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +//> set by a previous call to DGEBAL; otherwise they should be +//> set to 1 and N respectively. See Further Details. +//> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> On entry, the N-by-N general matrix to be reduced. +//> On exit, the upper triangle and the first subdiagonal of A +//> are overwritten with the upper Hessenberg matrix H, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,N). +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (N-1) +//> The scalar factors of the elementary reflectors (see Further +//> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to +//> zero. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (LWORK) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The length of the array WORK. LWORK >= max(1,N). +//> 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> The matrix Q is represented as a product of (ihi-ilo) elementary +//> reflectors +//> +//> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +//> +//> Each H(i) has the form +//> +//> H(i) = I - tau * v * v**T +//> +//> where tau is a real scalar, and v is a real vector with +//> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +//> exit in A(i+2:ihi,i), and tau in TAU(i). +//> +//> The contents of A are illustrated by the following example, with +//> n = 7, ilo = 2 and ihi = 6: +//> +//> on entry, on exit, +//> +//> ( a a a a a a a ) ( a a h h h h a ) +//> ( a a a a a a ) ( a h h h h a ) +//> ( a a a a a a ) ( h h h h h h ) +//> ( a a a a a a ) ( v2 h h h h h ) +//> ( a a a a a a ) ( v2 v3 h h h h ) +//> ( a a a a a a ) ( v2 v3 v4 h h h ) +//> ( a ) ( a ) +//> +//> where a denotes an element of the original matrix A, h denotes a +//> modified element of the upper Hessenberg matrix H, and vi denotes an +//> element of the vector defining H(i). +//> +//> This file is a slight modification of LAPACK-3.0's DGEHRD +//> subroutine incorporating improvements proposed by Quintana-Orti and +//> Van de Geijn (2006). (See DLAHR2.) +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgehrd_(int *n, int *ilo, int *ihi, double *a, int *lda, + double *tau, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__3 = 3; + int c__2 = 2; + int c__65 = 65; + double c_b25 = -1.; + double c_b26 = 1.; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3, i__4; + + // Local variables + int i__, j, ib; + double ei; + int nb, nh, nx, iwt; + extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *, + double *, double *, int *, double *, int *, double *, double *, + int *); + int nbmin, iinfo; + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, int *, + int *, double *, double *, int *, double *, int *), daxpy_(int *, + double *, double *, int *, double *, int *), dgehd2_(int *, int *, + int *, double *, int *, double *, double *, int *), dlahr2_(int * + , int *, int *, double *, int *, double *, double *, int *, + double *, int *), dlarfb_(char *, char *, char *, char *, int *, + int *, int *, double *, int *, double *, int *, double *, int *, + double *, int *), xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + int ldwork, lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + --tau; + --work; + + // Function Body + *info = 0; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > max(1,*n)) { + *info = -2; + } else if (*ihi < min(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < max(1,*n)) { + *info = -5; + } else if (*lwork < max(1,*n) && ! lquery) { + *info = -8; + } + if (*info == 0) { + // + // Compute the workspace requirements + // + // Computing MIN + i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1); + nb = min(i__1,i__2); + lwkopt = *n * nb + 4160; + work[1] = (double) lwkopt; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEHRD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + // + // Set elements 1:ILO-1 and IHI:N-1 of TAU to zero + // + i__1 = *ilo - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.; +// L10: + } + i__1 = *n - 1; + for (i__ = max(1,*ihi); i__ <= i__1; ++i__) { + tau[i__] = 0.; +// L20: + } + // + // Quick return if possible + // + nh = *ihi - *ilo + 1; + if (nh <= 1) { + work[1] = 1.; + return 0; + } + // + // Determine the block size + // + // Computing MIN + i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1); + nb = min(i__1,i__2); + nbmin = 2; + if (nb > 1 && nb < nh) { + // + // 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, "DGEHRD", " ", n, ilo, ihi, &c_n1); + nx = max(i__1,i__2); + if (nx < nh) { + // + // Determine if workspace is large enough for blocked code + // + if (*lwork < *n * nb + 4160) { + // + // Not enough workspace to use optimal NB: determine the + // minimum value of NB, and reduce NB or force use of + // unblocked code + // + // Computing MAX + i__1 = 2, i__2 = ilaenv_(&c__2, "DGEHRD", " ", n, ilo, ihi, & + c_n1); + nbmin = max(i__1,i__2); + if (*lwork >= *n * nbmin + 4160) { + nb = (*lwork - 4160) / *n; + } else { + nb = 1; + } + } + } + } + ldwork = *n; + if (nb < nbmin || nb >= nh) { + // + // Use unblocked code below + // + i__ = *ilo; + } else { + // + // Use blocked code + // + iwt = *n * nb + 1; + i__1 = *ihi - 1 - nx; + i__2 = nb; + for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + // Computing MIN + i__3 = nb, i__4 = *ihi - i__; + ib = min(i__3,i__4); + // + // Reduce columns i:i+ib-1 to Hessenberg form, returning the + // matrices V and T of the block reflector H = I - V*T*V**T + // which performs the reduction, and also the matrix Y = A*V*T + // + dlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], & + work[iwt], &c__65, &work[1], &ldwork); + // + // Apply the block reflector H to A(1:ihi,i+ib:ihi) from the + // right, computing A := A - Y * V**T. V(i+ib,ib-1) must be set + // to 1 + // + ei = a[i__ + ib + (i__ + ib - 1) * a_dim1]; + a[i__ + ib + (i__ + ib - 1) * a_dim1] = 1.; + i__3 = *ihi - i__ - ib + 1; + dgemm_("No transpose", "Transpose", ihi, &i__3, &ib, &c_b25, & + work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, & + c_b26, &a[(i__ + ib) * a_dim1 + 1], lda); + a[i__ + ib + (i__ + ib - 1) * a_dim1] = ei; + // + // Apply the block reflector H to A(1:i,i+1:i+ib-1) from the + // right + // + i__3 = ib - 1; + dtrmm_("Right", "Lower", "Transpose", "Unit", &i__, &i__3, &c_b26, + &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &ldwork); + i__3 = ib - 2; + for (j = 0; j <= i__3; ++j) { + daxpy_(&i__, &c_b25, &work[ldwork * j + 1], &c__1, &a[(i__ + + j + 1) * a_dim1 + 1], &c__1); +// L30: + } + // + // Apply the block reflector H to A(i+1:ihi,i+ib:n) from the + // left + // + i__3 = *ihi - i__; + i__4 = *n - i__ - ib + 1; + dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, & + i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, &work[iwt], & + c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], & + ldwork); +// L40: + } + } + // + // Use unblocked code to reduce the rest of the matrix + // + dgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo); + work[1] = (double) lwkopt; + return 0; + // + // End of DGEHRD + // +} // dgehrd_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DHSEQR +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DHSEQR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, +// LDZ, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N +// CHARACTER COMPZ, JOB +// .. +// .. Array Arguments .. +// DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), +// $ Z( LDZ, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DHSEQR computes the eigenvalues of a Hessenberg matrix H +//> and, optionally, the matrices T and Z from the Schur decomposition +//> H = Z T Z**T, where T is an upper quasi-triangular matrix (the +//> Schur form), and Z is the orthogonal matrix of Schur vectors. +//> +//> Optionally Z may be postmultiplied into an input orthogonal +//> matrix Q so that this routine can give the Schur factorization +//> of a matrix A which has been reduced to the Hessenberg form H +//> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] JOB +//> \verbatim +//> JOB is CHARACTER*1 +//> = 'E': compute eigenvalues only; +//> = 'S': compute eigenvalues and the Schur form T. +//> \endverbatim +//> +//> \param[in] COMPZ +//> \verbatim +//> COMPZ is CHARACTER*1 +//> = 'N': no Schur vectors are computed; +//> = 'I': Z is initialized to the unit matrix and the matrix Z +//> of Schur vectors of H is returned; +//> = 'V': Z must contain an orthogonal matrix Q on entry, and +//> the product Q*Z is returned. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix H. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> +//> It is assumed that H is already upper triangular in rows +//> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +//> set by a previous call to DGEBAL, and then passed to ZGEHRD +//> when the matrix output by DGEBAL is reduced to Hessenberg +//> form. Otherwise ILO and IHI should be set to 1 and N +//> respectively. If N > 0, then 1 <= ILO <= IHI <= N. +//> If N = 0, then ILO = 1 and IHI = 0. +//> \endverbatim +//> +//> \param[in,out] H +//> \verbatim +//> H is DOUBLE PRECISION array, dimension (LDH,N) +//> On entry, the upper Hessenberg matrix H. +//> On exit, if INFO = 0 and JOB = 'S', then H contains the +//> upper quasi-triangular matrix T from the Schur decomposition +//> (the Schur form); 2-by-2 diagonal blocks (corresponding to +//> complex conjugate pairs of eigenvalues) are returned in +//> standard form, with H(i,i) = H(i+1,i+1) and +//> H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and JOB = 'E', the +//> contents of H are unspecified on exit. (The output value of +//> H when INFO > 0 is given under the description of INFO +//> below.) +//> +//> Unlike earlier versions of DHSEQR, this subroutine may +//> explicitly H(i,j) = 0 for i > j and j = 1, 2, ... ILO-1 +//> or j = IHI+1, IHI+2, ... N. +//> \endverbatim +//> +//> \param[in] LDH +//> \verbatim +//> LDH is INTEGER +//> The leading dimension of the array H. LDH >= max(1,N). +//> \endverbatim +//> +//> \param[out] WR +//> \verbatim +//> WR is DOUBLE PRECISION array, dimension (N) +//> \endverbatim +//> +//> \param[out] WI +//> \verbatim +//> WI is DOUBLE PRECISION array, dimension (N) +//> +//> The real and imaginary parts, respectively, of the computed +//> eigenvalues. If two eigenvalues are computed as a complex +//> conjugate pair, they are stored in consecutive elements of +//> WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and +//> WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in +//> the same order as on the diagonal of the Schur form returned +//> in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 +//> diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +//> WI(i+1) = -WI(i). +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (LDZ,N) +//> If COMPZ = 'N', Z is not referenced. +//> If COMPZ = 'I', on entry Z need not be set and on exit, +//> if INFO = 0, Z contains the orthogonal matrix Z of the Schur +//> vectors of H. If COMPZ = 'V', on entry Z must contain an +//> N-by-N matrix Q, which is assumed to be equal to the unit +//> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, +//> if INFO = 0, Z contains Q*Z. +//> Normally Q is the orthogonal matrix generated by DORGHR +//> after the call to DGEHRD which formed the Hessenberg matrix +//> H. (The output value of Z when INFO > 0 is given under +//> the description of INFO below.) +//> \endverbatim +//> +//> \param[in] LDZ +//> \verbatim +//> LDZ is INTEGER +//> The leading dimension of the array Z. if COMPZ = 'I' or +//> COMPZ = 'V', then LDZ >= MAX(1,N). Otherwise, LDZ >= 1. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (LWORK) +//> On exit, if INFO = 0, WORK(1) returns an estimate of +//> the optimal value for LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the array WORK. LWORK >= max(1,N) +//> is sufficient and delivers very good and sometimes +//> optimal performance. However, LWORK as large as 11*N +//> may be required for optimal performance. A workspace +//> query is recommended to determine the optimal workspace +//> size. +//> +//> If LWORK = -1, then DHSEQR does a workspace query. +//> In this case, DHSEQR checks the input parameters and +//> estimates the optimal workspace size for the given +//> values of N, ILO and IHI. The estimate is returned +//> in WORK(1). No error message related to LWORK is +//> issued by XERBLA. Neither H nor Z are accessed. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal +//> value +//> > 0: if INFO = i, DHSEQR failed to compute all of +//> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +//> and WI contain those eigenvalues which have been +//> successfully computed. (Failures are rare.) +//> +//> If INFO > 0 and JOB = 'E', then on exit, the +//> remaining unconverged eigenvalues are the eigen- +//> values of the upper Hessenberg matrix rows and +//> columns ILO through INFO of the final, output +//> value of H. +//> +//> If INFO > 0 and JOB = 'S', then on exit +//> +//> (*) (initial value of H)*U = U*(final value of H) +//> +//> where U is an orthogonal matrix. The final +//> value of H is upper Hessenberg and quasi-triangular +//> in rows and columns INFO+1 through IHI. +//> +//> If INFO > 0 and COMPZ = 'V', then on exit +//> +//> (final value of Z) = (initial value of Z)*U +//> +//> where U is the orthogonal matrix in (*) (regard- +//> less of the value of JOB.) +//> +//> If INFO > 0 and COMPZ = 'I', then on exit +//> (final value of Z) = U +//> where U is the orthogonal matrix in (*) (regard- +//> less of the value of JOB.) +//> +//> If INFO > 0 and COMPZ = 'N', then Z is not +//> accessed. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +//> \par Contributors: +// ================== +//> +//> Karen Braman and Ralph Byers, Department of Mathematics, +//> University of Kansas, USA +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> Default values supplied by +//> ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). +//> It is suggested that these defaults be adjusted in order +//> to attain best performance in each particular +//> computational environment. +//> +//> ISPEC=12: The DLAHQR vs DLAQR0 crossover point. +//> Default: 75. (Must be at least 11.) +//> +//> ISPEC=13: Recommended deflation window size. +//> This depends on ILO, IHI and NS. NS is the +//> number of simultaneous shifts returned +//> by ILAENV(ISPEC=15). (See ISPEC=15 below.) +//> The default for (IHI-ILO+1) <= 500 is NS. +//> The default for (IHI-ILO+1) > 500 is 3*NS/2. +//> +//> ISPEC=14: Nibble crossover point. (See IPARMQ for +//> details.) Default: 14% of deflation window +//> size. +//> +//> ISPEC=15: Number of simultaneous shifts in a multishift +//> QR iteration. +//> +//> If IHI-ILO+1 is ... +//> +//> greater than ...but less ... the +//> or equal to ... than default is +//> +//> 1 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 some or all matrices of this order +//> are passed to the implicit double shift routine +//> DLAHQR and this parameter is ignored. See +//> ISPEC=12 above and comments in IPARMQ for +//> details. +//> +//> (**) The asterisks (**) indicate an ad-hoc +//> function of N increasing from 10 to 64. +//> +//> ISPEC=16: Select structured matrix multiply. +//> If the number of simultaneous shifts (specified +//> by ISPEC=15) is less than 14, then the default +//> for ISPEC=16 is 0. Otherwise the default for +//> ISPEC=16 is 2. +//> \endverbatim +// +//> \par References: +// ================ +//> +//> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +//> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +//> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +//> 929--947, 2002. +//> \n +//> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +//> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +//> of Matrix Analysis, volume 23, pages 948--973, 2002. +// +// ===================================================================== +/* Subroutine */ int dhseqr_(char *job, char *compz, int *n, int *ilo, int * + ihi, double *h__, int *ldh, double *wr, double *wi, double *z__, int * + ldz, double *work, int *lwork, int *info) +{ + // Table of constant values + double c_b11 = 0.; + double c_b12 = 1.; + int c__12 = 12; + int c__2 = 2; + int c__49 = 49; + + // System generated locals + address a__1[2]; + int h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3; + double d__1; + char ch__1[2+1]={'\0'}; + + // Local variables + int i__; + double hl[2401] /* was [49][49] */; + int kbot, nmin; + extern int lsame_(char *, char *); + int initz; + double workl[49]; + int wantt, wantz; + extern /* Subroutine */ int dlaqr0_(int *, int *, int *, int *, int *, + double *, int *, double *, double *, int *, int *, double *, int * + , double *, int *, int *), dlahqr_(int *, int *, int *, int *, + int *, double *, int *, double *, double *, int *, int *, double * + , int *, int *), dlacpy_(char *, int *, int *, double *, int *, + double *, int *), dlaset_(char *, int *, int *, double *, double * + , double *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + extern /* Subroutine */ int xerbla_(char *, int *); + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // + // ==== Matrices of order NTINY or smaller must be processed by + // . DLAHQR because of insufficient subdiagonal scratch space. + // . (This is a hard limit.) ==== + // + // ==== NL allocates some local workspace to help small matrices + // . through a rare DLAHQR failure. NL > NTINY = 11 is + // . required and NL <= NMIN = ILAENV(ISPEC=12,...) is recom- + // . mended. (The default value of NMIN is 75.) Using NL = 49 + // . allows up to six simultaneous shifts and a 16-by-16 + // . deflation window. ==== + // .. + // .. Local Arrays .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // ==== Decode and check the input parameters. ==== + // + // Parameter adjustments + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + // Function Body + wantt = lsame_(job, "S"); + initz = lsame_(compz, "I"); + wantz = initz || lsame_(compz, "V"); + work[1] = (double) max(1,*n); + lquery = *lwork == -1; + *info = 0; + if (! lsame_(job, "E") && ! wantt) { + *info = -1; + } else if (! lsame_(compz, "N") && ! wantz) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1 || *ilo > max(1,*n)) { + *info = -4; + } else if (*ihi < min(*ilo,*n) || *ihi > *n) { + *info = -5; + } else if (*ldh < max(1,*n)) { + *info = -7; + } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) { + *info = -11; + } else if (*lwork < max(1,*n) && ! lquery) { + *info = -13; + } + if (*info != 0) { + // + // ==== Quick return in case of invalid argument. ==== + // + i__1 = -(*info); + xerbla_("DHSEQR", &i__1); + return 0; + } else if (*n == 0) { + // + // ==== Quick return in case N = 0; nothing to do. ==== + // + return 0; + } else if (lquery) { + // + // ==== Quick return in case of a workspace query ==== + // + dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[ + 1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); + // ==== Ensure reported workspace size is backward-compatible with + // . previous LAPACK versions. ==== + // Computing MAX + d__1 = (double) max(1,*n); + work[1] = max(d__1,work[1]); + return 0; + } else { + // + // ==== copy eigenvalues isolated by DGEBAL ==== + // + i__1 = *ilo - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + wr[i__] = h__[i__ + i__ * h_dim1]; + wi[i__] = 0.; +// L10: + } + i__1 = *n; + for (i__ = *ihi + 1; i__ <= i__1; ++i__) { + wr[i__] = h__[i__ + i__ * h_dim1]; + wi[i__] = 0.; +// L20: + } + // + // ==== Initialize Z, if requested ==== + // + if (initz) { + dlaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz); + } + // + // ==== Quick return if possible ==== + // + if (*ilo == *ihi) { + wr[*ilo] = h__[*ilo + *ilo * h_dim1]; + wi[*ilo] = 0.; + return 0; + } + // + // ==== DLAHQR/DLAQR0 crossover point ==== + // + // Writing concatenation + i__2[0] = 1, a__1[0] = job; + i__2[1] = 1, a__1[1] = compz; + s_cat(ch__1, a__1, i__2, &c__2); + nmin = ilaenv_(&c__12, "DHSEQR", ch__1, n, ilo, ihi, lwork); + nmin = max(11,nmin); + // + // ==== DLAQR0 for big matrices; DLAHQR for small ones ==== + // + if (*n > nmin) { + dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], + &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, + info); + } else { + // + // ==== Small matrix ==== + // + dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], + &wi[1], ilo, ihi, &z__[z_offset], ldz, info); + if (*info > 0) { + // + // ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds + // . when DLAHQR fails. ==== + // + kbot = *info; + if (*n >= 49) { + // + // ==== Larger matrices have enough subdiagonal scratch + // . space to call DLAQR0 directly. ==== + // + dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], + ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], + ldz, &work[1], lwork, info); + } else { + // + // ==== Tiny matrices don't have enough subdiagonal + // . scratch space to benefit from DLAQR0. Hence, + // . tiny matrices must be copied into a larger + // . array before calling DLAQR0. ==== + // + dlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49); + hl[*n + 1 + *n * 49 - 50] = 0.; + i__1 = 49 - *n; + dlaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * + 49 - 49], &c__49); + dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, & + wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, + workl, &c__49, info); + if (wantt || *info != 0) { + dlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh); + } + } + } + } + // + // ==== Clear out the trash, if necessary. ==== + // + if ((wantt || *info != 0) && *n > 2) { + i__1 = *n - 2; + i__3 = *n - 2; + dlaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh); + } + // + // ==== Ensure reported workspace size is backward-compatible with + // . previous LAPACK versions. ==== + // + // Computing MAX + d__1 = (double) max(1,*n); + work[1] = max(d__1,work[1]); + } + // + // ==== End of DHSEQR ==== + // + return 0; +} // dhseqr_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLABAD +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLABAD + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLABAD( SMALL, LARGE ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION LARGE, SMALL +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in,out] SMALL +//> \verbatim +//> SMALL is 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. +//> \endverbatim +//> +//> \param[in,out] LARGE +//> \verbatim +//> LARGE is 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. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlabad_(double *small, double *large) +{ + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLADIV + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLADIV( A, B, C, D, P, Q ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION A, B, C, D, P, Q +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLADIV performs complex division in real arithmetic +//> +//> a + i*b +//> p + i*q = --------- +//> c + i*d +//> +//> The algorithm is due to Michael Baudin and Robert L. Smith +//> and can be found in the paper +//> "A Robust Complex Division in Scilab" +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] B +//> \verbatim +//> B is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] C +//> \verbatim +//> C is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] D +//> \verbatim +//> D is DOUBLE PRECISION +//> The scalars a, b, c, and d in the above expression. +//> \endverbatim +//> +//> \param[out] P +//> \verbatim +//> P is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[out] Q +//> \verbatim +//> Q is DOUBLE PRECISION +//> The scalars p and q in the above expression. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date January 2013 +// +//> \ingroup doubleOTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dladiv_(double *a, double *b, double *c__, double *d__, + double *p, double *q) +{ + // System generated locals + double d__1, d__2; + + // Local variables + double s, aa, ab, bb, cc, cd, dd, be, un, ov, eps; + extern double dlamch_(char *); + extern /* Subroutine */ int dladiv1_(double *, double *, double *, double + *, double *, double *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // January 2013 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + aa = *a; + bb = *b; + cc = *c__; + dd = *d__; + // Computing MAX + d__1 = abs(*a), d__2 = abs(*b); + ab = max(d__1,d__2); + // Computing MAX + d__1 = abs(*c__), d__2 = abs(*d__); + cd = max(d__1,d__2); + s = 1.; + ov = dlamch_("Overflow threshold"); + un = dlamch_("Safe minimum"); + eps = dlamch_("Epsilon"); + be = 2. / (eps * eps); + if (ab >= ov * .5) { + aa *= .5; + bb *= .5; + s *= 2.; + } + if (cd >= ov * .5) { + cc *= .5; + dd *= .5; + s *= .5; + } + if (ab <= un * 2. / eps) { + aa *= be; + bb *= be; + s /= be; + } + if (cd <= un * 2. / eps) { + cc *= be; + dd *= be; + s *= be; + } + if (abs(*d__) <= abs(*c__)) { + dladiv1_(&aa, &bb, &cc, &dd, p, q); + } else { + dladiv1_(&bb, &aa, &dd, &cc, p, q); + *q = -(*q); + } + *p *= s; + *q *= s; + return 0; + // + // End of DLADIV + // +} // dladiv_ + +//> \ingroup doubleOTHERauxiliary +/* Subroutine */ int dladiv1_(double *a, double *b, double *c__, double *d__, + double *p, double *q) +{ + double r__, t; + extern double dladiv2_(double *, double *, double *, double *, double *, + double *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // January 2013 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Executable Statements .. + // + r__ = *d__ / *c__; + t = 1. / (*c__ + *d__ * r__); + *p = dladiv2_(a, b, c__, d__, &r__, &t); + *a = -(*a); + *q = dladiv2_(b, a, c__, d__, &r__, &t); + return 0; + // + // End of DLADIV1 + // +} // dladiv1_ + +//> \ingroup doubleOTHERauxiliary +double dladiv2_(double *a, double *b, double *c__, double *d__, double *r__, + double *t) +{ + // System generated locals + double ret_val; + + // Local variables + double br; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // January 2013 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // + // .. Local Scalars .. + // .. + // .. Executable Statements .. + // + if (*r__ != 0.) { + br = *b * *r__; + if (br != 0.) { + ret_val = (*a + br) * *t; + } else { + ret_val = *a * *t + *b * *t * *r__; + } + } else { + ret_val = (*a + *d__ * (*b / *c__)) * *t; + } + return ret_val; + // + // End of DLADIV12 + // +} // dladiv2_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form, by an orthogonal similarity transformation. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAEXC + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, +// INFO ) +// +// .. Scalar Arguments .. +// LOGICAL WANTQ +// INTEGER INFO, J1, LDQ, LDT, N, N1, N2 +// .. +// .. Array Arguments .. +// DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in +//> an upper quasi-triangular matrix T by an orthogonal similarity +//> transformation. +//> +//> T must be in Schur canonical form, that is, block upper triangular +//> with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block +//> has its diagonal elemnts equal and its off-diagonal elements of +//> opposite sign. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] WANTQ +//> \verbatim +//> WANTQ is LOGICAL +//> = .TRUE. : accumulate the transformation in the matrix Q; +//> = .FALSE.: do not accumulate the transformation. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix T. N >= 0. +//> \endverbatim +//> +//> \param[in,out] T +//> \verbatim +//> T is DOUBLE PRECISION array, dimension (LDT,N) +//> On entry, the upper quasi-triangular matrix T, in Schur +//> canonical form. +//> On exit, the updated matrix T, again in Schur canonical form. +//> \endverbatim +//> +//> \param[in] LDT +//> \verbatim +//> LDT is INTEGER +//> The leading dimension of the array T. LDT >= max(1,N). +//> \endverbatim +//> +//> \param[in,out] Q +//> \verbatim +//> Q is DOUBLE PRECISION array, dimension (LDQ,N) +//> On entry, if WANTQ is .TRUE., the orthogonal matrix Q. +//> On exit, if WANTQ is .TRUE., the updated matrix Q. +//> If WANTQ is .FALSE., Q is not referenced. +//> \endverbatim +//> +//> \param[in] LDQ +//> \verbatim +//> LDQ is INTEGER +//> The leading dimension of the array Q. +//> LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. +//> \endverbatim +//> +//> \param[in] J1 +//> \verbatim +//> J1 is INTEGER +//> The index of the first row of the first block T11. +//> \endverbatim +//> +//> \param[in] N1 +//> \verbatim +//> N1 is INTEGER +//> The order of the first block T11. N1 = 0, 1 or 2. +//> \endverbatim +//> +//> \param[in] N2 +//> \verbatim +//> N2 is INTEGER +//> The order of the second block T22. N2 = 0, 1 or 2. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (N) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> = 1: the transformed matrix T would be too far from Schur +//> form; the blocks are not swapped and T and Q are +//> unchanged. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlaexc_(int *wantq, int *n, double *t, int *ldt, double * + q, int *ldq, int *j1, int *n1, int *n2, double *work, int *info) +{ + // Table of constant values + int c__1 = 1; + int c__4 = 4; + int c_false = FALSE_; + int c_n1 = -1; + int c__2 = 2; + int c__3 = 3; + + // System generated locals + int q_dim1, q_offset, t_dim1, t_offset, i__1; + double d__1, d__2, d__3; + + // Local variables + double d__[16] /* was [4][4] */; + int k; + double u[3], x[4] /* was [2][2] */; + int j2, j3, j4; + double u1[3], u2[3]; + int nd; + double cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1, tau2; + int ierr; + double temp; + extern /* Subroutine */ int drot_(int *, double *, int *, double *, int *, + double *, double *); + double scale, dnorm, xnorm; + extern /* Subroutine */ int dlanv2_(double *, double *, double *, double * + , double *, double *, double *, double *, double *, double *), + dlasy2_(int *, int *, int *, int *, int *, double *, int *, + double *, int *, double *, int *, double *, double *, int *, + double *, int *); + extern double dlamch_(char *), dlange_(char *, int *, int *, double *, + int *, double *); + extern /* Subroutine */ int dlarfg_(int *, double *, double *, int *, + double *), dlacpy_(char *, int *, int *, double *, int *, double * + , int *), dlartg_(double *, double *, double *, double *, double * + ), dlarfx_(char *, int *, int *, double *, double *, double *, + int *, double *); + double thresh, smlnum; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. Local Arrays .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Parameter adjustments + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --work; + + // Function Body + *info = 0; + // + // Quick return if possible + // + if (*n == 0 || *n1 == 0 || *n2 == 0) { + return 0; + } + if (*j1 + *n1 > *n) { + return 0; + } + j2 = *j1 + 1; + j3 = *j1 + 2; + j4 = *j1 + 3; + if (*n1 == 1 && *n2 == 1) { + // + // Swap two 1-by-1 blocks. + // + t11 = t[*j1 + *j1 * t_dim1]; + t22 = t[j2 + j2 * t_dim1]; + // + // Determine the transformation to perform the interchange. + // + d__1 = t22 - t11; + dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp); + // + // Apply transformation to the matrix T. + // + if (j3 <= *n) { + i__1 = *n - *j1 - 1; + drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1], + ldt, &cs, &sn); + } + i__1 = *j1 - 1; + drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1, + &cs, &sn); + t[*j1 + *j1 * t_dim1] = t22; + t[j2 + j2 * t_dim1] = t11; + if (*wantq) { + // + // Accumulate transformation in the matrix Q. + // + drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1, + &cs, &sn); + } + } else { + // + // Swapping involves at least one 2-by-2 block. + // + // Copy the diagonal block of order N1+N2 to the local array D + // and compute its norm. + // + nd = *n1 + *n2; + dlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4); + dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]); + // + // Compute machine-dependent threshold for test for accepting + // swap. + // + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + // Computing MAX + d__1 = eps * 10. * dnorm; + thresh = max(d__1,smlnum); + // + // Solve T11*X - X*T22 = scale*T12 for X. + // + dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 + + (*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, & + scale, x, &c__2, &xnorm, &ierr); + // + // Swap the adjacent diagonal blocks. + // + k = *n1 + *n1 + *n2 - 3; + switch (k) { + case 1: goto L10; + case 2: goto L20; + case 3: goto L30; + } +L10: + // + // N1 = 1, N2 = 2: generate elementary reflector H so that: + // + // ( scale, X11, X12 ) H = ( 0, 0, * ) + // + u[0] = scale; + u[1] = x[0]; + u[2] = x[2]; + dlarfg_(&c__3, &u[2], u, &c__1, &tau); + u[2] = 1.; + t11 = t[*j1 + *j1 * t_dim1]; + // + // Perform swap provisionally on diagonal block in D. + // + dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + // + // Test whether to reject swap. + // + // Computing MAX + d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = max(d__2,d__3), d__3 = + (d__1 = d__[10] - t11, abs(d__1)); + if (max(d__2,d__3) > thresh) { + goto L50; + } + // + // Accept swap: apply transformation to the entire matrix T. + // + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]) + ; + t[j3 + *j1 * t_dim1] = 0.; + t[j3 + j2 * t_dim1] = 0.; + t[j3 + j3 * t_dim1] = t11; + if (*wantq) { + // + // Accumulate transformation in the matrix Q. + // + dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ + 1]); + } + goto L40; +L20: + // + // N1 = 2, N2 = 1: generate elementary reflector H so that: + // + // H ( -X11 ) = ( * ) + // ( -X21 ) = ( 0 ) + // ( scale ) = ( 0 ) + // + u[0] = -x[0]; + u[1] = -x[1]; + u[2] = scale; + dlarfg_(&c__3, u, &u[1], &c__1, &tau); + u[0] = 1.; + t33 = t[j3 + j3 * t_dim1]; + // + // Perform swap provisionally on diagonal block in D. + // + dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + // + // Test whether to reject swap. + // + // Computing MAX + d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = max(d__2,d__3), d__3 = + (d__1 = d__[0] - t33, abs(d__1)); + if (max(d__2,d__3) > thresh) { + goto L50; + } + // + // Accept swap: apply transformation to the entire matrix T. + // + dlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]) + ; + i__1 = *n - *j1; + dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[ + 1]); + t[*j1 + *j1 * t_dim1] = t33; + t[j2 + *j1 * t_dim1] = 0.; + t[j3 + *j1 * t_dim1] = 0.; + if (*wantq) { + // + // Accumulate transformation in the matrix Q. + // + dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ + 1]); + } + goto L40; +L30: + // + // N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so + // that: + // + // H(2) H(1) ( -X11 -X12 ) = ( * * ) + // ( -X21 -X22 ) ( 0 * ) + // ( scale 0 ) ( 0 0 ) + // ( 0 scale ) ( 0 0 ) + // + u1[0] = -x[0]; + u1[1] = -x[1]; + u1[2] = scale; + dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1); + u1[0] = 1.; + temp = -tau1 * (x[2] + u1[1] * x[3]); + u2[0] = -temp * u1[1] - x[3]; + u2[1] = -temp * u1[2]; + u2[2] = scale; + dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2); + u2[0] = 1.; + // + // Perform swap provisionally on diagonal block in D. + // + dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1]); + dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1]); + dlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]); + dlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]); + // + // Test whether to reject swap. + // + // Computing MAX + d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = max(d__1,d__2), d__2 = + abs(d__[3]), d__1 = max(d__1,d__2), d__2 = abs(d__[7]); + if (max(d__1,d__2) > thresh) { + goto L50; + } + // + // Accept swap: apply transformation to the entire matrix T. + // + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[ + 1]); + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1] + ); + t[j3 + *j1 * t_dim1] = 0.; + t[j3 + j2 * t_dim1] = 0.; + t[j4 + *j1 * t_dim1] = 0.; + t[j4 + j2 * t_dim1] = 0.; + if (*wantq) { + // + // Accumulate transformation in the matrix Q. + // + dlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, & + work[1]); + dlarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[ + 1]); + } +L40: + if (*n2 == 2) { + // + // Standardize new 2-by-2 block T11 + // + dlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + * + j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, & + wi2, &cs, &sn); + i__1 = *n - *j1 - 1; + drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2) + * t_dim1], ldt, &cs, &sn); + i__1 = *j1 - 1; + drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], & + c__1, &cs, &sn); + if (*wantq) { + drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], & + c__1, &cs, &sn); + } + } + if (*n1 == 2) { + // + // Standardize new 2-by-2 block T22 + // + j3 = *j1 + *n2; + j4 = j3 + 1; + dlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 * + t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, & + cs, &sn); + if (j3 + 2 <= *n) { + i__1 = *n - j3 - 1; + drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2) + * t_dim1], ldt, &cs, &sn); + } + i__1 = j3 - 1; + drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], & + c__1, &cs, &sn); + if (*wantq) { + drot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], & + c__1, &cs, &sn); + } + } + } + return 0; + // + // Exit with INFO = 1 if swap was rejected. + // +L50: + *info = 1; + return 0; + // + // End of DLAEXC + // +} // dlaexc_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAHQR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +// ILOZ, IHIZ, Z, LDZ, INFO ) +// +// .. Scalar Arguments .. +// INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N +// LOGICAL WANTT, WANTZ +// .. +// .. Array Arguments .. +// DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLAHQR is an auxiliary routine called by DHSEQR to update the +//> eigenvalues and Schur decomposition already computed by DHSEQR, by +//> dealing with the Hessenberg submatrix in rows and columns ILO to +//> IHI. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] WANTT +//> \verbatim +//> WANTT is LOGICAL +//> = .TRUE. : the full Schur form T is required; +//> = .FALSE.: only eigenvalues are required. +//> \endverbatim +//> +//> \param[in] WANTZ +//> \verbatim +//> WANTZ is LOGICAL +//> = .TRUE. : the matrix of Schur vectors Z is required; +//> = .FALSE.: Schur vectors are not required. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix H. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> It is assumed that H is already upper quasi-triangular in +//> rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless +//> ILO = 1). DLAHQR works primarily with the Hessenberg +//> submatrix in rows and columns ILO to IHI, but applies +//> transformations to all of H if WANTT is .TRUE.. +//> 1 <= ILO <= max(1,IHI); IHI <= N. +//> \endverbatim +//> +//> \param[in,out] H +//> \verbatim +//> H is DOUBLE PRECISION array, dimension (LDH,N) +//> On entry, the upper Hessenberg matrix H. +//> On exit, if INFO is zero and if WANTT is .TRUE., H is upper +//> quasi-triangular in rows and columns ILO:IHI, with any +//> 2-by-2 diagonal blocks in standard form. If INFO is zero +//> and WANTT is .FALSE., the contents of H are unspecified on +//> exit. The output state of H if INFO is nonzero is given +//> below under the description of INFO. +//> \endverbatim +//> +//> \param[in] LDH +//> \verbatim +//> LDH is INTEGER +//> The leading dimension of the array H. LDH >= max(1,N). +//> \endverbatim +//> +//> \param[out] WR +//> \verbatim +//> WR is DOUBLE PRECISION array, dimension (N) +//> \endverbatim +//> +//> \param[out] WI +//> \verbatim +//> WI is DOUBLE PRECISION array, dimension (N) +//> The real and imaginary parts, respectively, of the computed +//> eigenvalues ILO to IHI are stored in the corresponding +//> elements of WR and WI. If two eigenvalues are computed as a +//> complex conjugate pair, they are stored in consecutive +//> elements of WR and WI, say the i-th and (i+1)th, with +//> WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the +//> eigenvalues are stored in the same order as on the diagonal +//> of the Schur form returned in H, with WR(i) = H(i,i), and, if +//> H(i:i+1,i:i+1) is a 2-by-2 diagonal block, +//> WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). +//> \endverbatim +//> +//> \param[in] ILOZ +//> \verbatim +//> ILOZ is INTEGER +//> \endverbatim +//> +//> \param[in] IHIZ +//> \verbatim +//> IHIZ is INTEGER +//> Specify the rows of Z to which transformations must be +//> applied if WANTZ is .TRUE.. +//> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (LDZ,N) +//> If WANTZ is .TRUE., on entry Z must contain the current +//> matrix Z of transformations accumulated by DHSEQR, and on +//> exit Z has been updated; transformations are applied only to +//> the submatrix Z(ILOZ:IHIZ,ILO:IHI). +//> If WANTZ is .FALSE., Z is not referenced. +//> \endverbatim +//> +//> \param[in] LDZ +//> \verbatim +//> LDZ is INTEGER +//> The leading dimension of the array Z. LDZ >= max(1,N). +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> > 0: If INFO = i, DLAHQR failed to compute all the +//> eigenvalues ILO to IHI in a total of 30 iterations +//> per eigenvalue; elements i+1:ihi of WR and WI +//> contain those eigenvalues which have been +//> successfully computed. +//> +//> If INFO > 0 and WANTT is .FALSE., then on exit, +//> the remaining unconverged eigenvalues are the +//> eigenvalues of the upper Hessenberg matrix rows +//> and columns ILO through INFO of the final, output +//> value of H. +//> +//> If INFO > 0 and WANTT is .TRUE., then on exit +//> (*) (initial value of H)*U = U*(final value of H) +//> where U is an orthogonal matrix. The final +//> value of H is upper Hessenberg and triangular in +//> rows and columns INFO+1 through IHI. +//> +//> If INFO > 0 and WANTZ is .TRUE., then on exit +//> (final value of Z) = (initial value of Z)*U +//> where U is the orthogonal matrix in (*) +//> (regardless of the value of WANTT.) +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 02-96 Based on modifications by +//> David Day, Sandia National Laboratory, USA +//> +//> 12-04 Further modifications by +//> Ralph Byers, University of Kansas, USA +//> This is a modified version of DLAHQR from LAPACK version 3.0. +//> It is (1) more robust against overflow and underflow and +//> (2) adopts the more conservative Ahues & Tisseur stopping +//> criterion (LAWN 122, 1997). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlahqr_(int *wantt, int *wantz, int *n, int *ilo, int * + ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int * + ihiz, double *z__, int *ldz, int *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4; + + // Local variables + int i__, j, k, l, m; + double s, v[3]; + int i1, i2; + double t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs; + int nh; + double sn; + int nr; + double tr; + int nz; + double det, h21s; + int its; + double ulp, sum, tst, rt1i, rt2i, rt1r, rt2r; + extern /* Subroutine */ int drot_(int *, double *, int *, double *, int *, + double *, double *), dcopy_(int *, double *, int *, double *, + int *); + int itmax; + extern /* Subroutine */ int dlanv2_(double *, double *, double *, double * + , double *, double *, double *, double *, double *, double *), + dlabad_(double *, double *); + extern double dlamch_(char *); + extern /* Subroutine */ int dlarfg_(int *, double *, double *, int *, + double *); + double safmin, safmax, rtdisc, smlnum; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ========================================================= + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. Local Arrays .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Parameter adjustments + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + + // Function Body + *info = 0; + // + // Quick return if possible + // + if (*n == 0) { + return 0; + } + if (*ilo == *ihi) { + wr[*ilo] = h__[*ilo + *ilo * h_dim1]; + wi[*ilo] = 0.; + return 0; + } + // + // ==== clear out the trash ==== + i__1 = *ihi - 3; + for (j = *ilo; j <= i__1; ++j) { + h__[j + 2 + j * h_dim1] = 0.; + h__[j + 3 + j * h_dim1] = 0.; +// L10: + } + if (*ilo <= *ihi - 2) { + h__[*ihi + (*ihi - 2) * h_dim1] = 0.; + } + nh = *ihi - *ilo + 1; + nz = *ihiz - *iloz + 1; + // + // Set machine-dependent constants for the stopping criterion. + // + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((double) nh / ulp); + // + // I1 and I2 are the indices of the first row and last column of H + // to which transformations must be applied. If eigenvalues only are + // being computed, I1 and I2 are set inside the main loop. + // + if (*wantt) { + i1 = 1; + i2 = *n; + } + // + // ITMAX is the total number of QR iterations allowed. + // + itmax = max(10,nh) * 30; + // + // The main loop begins here. I is the loop index and decreases from + // IHI to ILO in steps of 1 or 2. Each iteration of the loop works + // with the active submatrix in rows and columns L to I. + // Eigenvalues I+1 to IHI have already converged. Either L = ILO or + // H(L,L-1) is negligible so that the matrix splits. + // + i__ = *ihi; +L20: + l = *ilo; + if (i__ < *ilo) { + goto L160; + } + // + // Perform QR iterations on rows and columns ILO to I until a + // submatrix of order 1 or 2 splits off at the bottom because a + // subdiagonal element has become negligible. + // + i__1 = itmax; + for (its = 0; its <= i__1; ++its) { + // + // Look for a single small subdiagonal element. + // + i__2 = l + 1; + for (k = i__; k >= i__2; --k) { + if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) { + goto L40; + } + tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 = + h__[k + k * h_dim1], abs(d__2)); + if (tst == 0.) { + if (k - 2 >= *ilo) { + tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1)); + } + if (k + 1 <= *ihi) { + tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)); + } + } + // ==== The following is a conservative small subdiagonal + // . deflation criterion due to Ahues & Tisseur (LAWN 122, + // . 1997). It has better mathematical foundation and + // . improves accuracy in some cases. ==== + if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) { + // Computing MAX + d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = ( + d__2 = h__[k - 1 + k * h_dim1], abs(d__2)); + ab = max(d__3,d__4); + // Computing MIN + d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = ( + d__2 = h__[k - 1 + k * h_dim1], abs(d__2)); + ba = min(d__3,d__4); + // Computing MAX + d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 = + h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], + abs(d__2)); + aa = max(d__3,d__4); + // Computing MIN + d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 = + h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], + abs(d__2)); + bb = min(d__3,d__4); + s = aa + ab; + // Computing MAX + d__1 = smlnum, d__2 = ulp * (bb * (aa / s)); + if (ba * (ab / s) <= max(d__1,d__2)) { + goto L40; + } + } +// L30: + } +L40: + l = k; + if (l > *ilo) { + // + // H(L,L-1) is negligible + // + h__[l + (l - 1) * h_dim1] = 0.; + } + // + // Exit from loop if a submatrix of order 1 or 2 has split off. + // + if (l >= i__ - 1) { + goto L150; + } + // + // Now the active submatrix is in rows and columns L to I. If + // eigenvalues only are being computed, only the active submatrix + // need be transformed. + // + if (! (*wantt)) { + i1 = l; + i2 = i__; + } + if (its == 10) { + // + // Exceptional shift. + // + s = (d__1 = h__[l + 1 + l * h_dim1], abs(d__1)) + (d__2 = h__[l + + 2 + (l + 1) * h_dim1], abs(d__2)); + h11 = s * .75 + h__[l + l * h_dim1]; + h12 = s * -.4375; + h21 = s; + h22 = h11; + } else if (its == 20) { + // + // Exceptional shift. + // + s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 = + h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2)); + h11 = s * .75 + h__[i__ + i__ * h_dim1]; + h12 = s * -.4375; + h21 = s; + h22 = h11; + } else { + // + // Prepare to use Francis' double shift + // (i.e. 2nd degree generalized Rayleigh quotient) + // + h11 = h__[i__ - 1 + (i__ - 1) * h_dim1]; + h21 = h__[i__ + (i__ - 1) * h_dim1]; + h12 = h__[i__ - 1 + i__ * h_dim1]; + h22 = h__[i__ + i__ * h_dim1]; + } + s = abs(h11) + abs(h12) + abs(h21) + abs(h22); + if (s == 0.) { + rt1r = 0.; + rt1i = 0.; + rt2r = 0.; + rt2i = 0.; + } else { + h11 /= s; + h21 /= s; + h12 /= s; + h22 /= s; + tr = (h11 + h22) / 2.; + det = (h11 - tr) * (h22 - tr) - h12 * h21; + rtdisc = sqrt((abs(det))); + if (det >= 0.) { + // + // ==== complex conjugate shifts ==== + // + rt1r = tr * s; + rt2r = rt1r; + rt1i = rtdisc * s; + rt2i = -rt1i; + } else { + // + // ==== real shifts (use only one of them) ==== + // + rt1r = tr + rtdisc; + rt2r = tr - rtdisc; + if ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs( + d__2))) { + rt1r *= s; + rt2r = rt1r; + } else { + rt2r *= s; + rt1r = rt2r; + } + rt1i = 0.; + rt2i = 0.; + } + } + // + // Look for two consecutive small subdiagonal elements. + // + i__2 = l; + for (m = i__ - 2; m >= i__2; --m) { + // Determine the effect of starting the double-shift QR + // iteration at row M, and see if this would make H(M,M-1) + // negligible. (The following uses scaling to avoid + // overflows and most underflows.) + // + h21s = h__[m + 1 + m * h_dim1]; + s = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__1)) + abs(rt2i) + + abs(h21s); + h21s = h__[m + 1 + m * h_dim1] / s; + v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] - + rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i + / s); + v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1] + - rt1r - rt2r); + v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1]; + s = abs(v[0]) + abs(v[1]) + abs(v[2]); + v[0] /= s; + v[1] /= s; + v[2] /= s; + if (m == l) { + goto L60; + } + if ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) + + abs(v[2])) <= ulp * abs(v[0]) * ((d__2 = h__[m - 1 + (m - + 1) * h_dim1], abs(d__2)) + (d__3 = h__[m + m * h_dim1], + abs(d__3)) + (d__4 = h__[m + 1 + (m + 1) * h_dim1], abs( + d__4)))) { + goto L60; + } +// L50: + } +L60: + // + // Double-shift QR step + // + i__2 = i__ - 1; + for (k = m; k <= i__2; ++k) { + // + // The first iteration of this loop determines a reflection G + // from the vector V and applies it from left and right to H, + // thus creating a nonzero bulge below the subdiagonal. + // + // Each subsequent iteration determines a reflection G to + // restore the Hessenberg form in the (K-1)th column, and thus + // chases the bulge one step toward the bottom of the active + // submatrix. NR is the order of G. + // + // Computing MIN + i__3 = 3, i__4 = i__ - k + 1; + nr = min(i__3,i__4); + if (k > m) { + dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); + } + dlarfg_(&nr, v, &v[1], &c__1, &t1); + if (k > m) { + h__[k + (k - 1) * h_dim1] = v[0]; + h__[k + 1 + (k - 1) * h_dim1] = 0.; + if (k < i__ - 1) { + h__[k + 2 + (k - 1) * h_dim1] = 0.; + } + } else if (m > l) { + // ==== Use the following instead of + // . H( K, K-1 ) = -H( K, K-1 ) to + // . avoid a bug when v(2) and v(3) + // . underflow. ==== + h__[k + (k - 1) * h_dim1] *= 1. - t1; + } + v2 = v[1]; + t2 = t1 * v2; + if (nr == 3) { + v3 = v[2]; + t3 = t1 * v3; + // + // Apply G from the left to transform the rows of the matrix + // in columns K to I2. + // + i__3 = i2; + for (j = k; j <= i__3; ++j) { + sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] + + v3 * h__[k + 2 + j * h_dim1]; + h__[k + j * h_dim1] -= sum * t1; + h__[k + 1 + j * h_dim1] -= sum * t2; + h__[k + 2 + j * h_dim1] -= sum * t3; +// L70: + } + // + // Apply G from the right to transform the columns of the + // matrix in rows I1 to min(K+3,I). + // + // Computing MIN + i__4 = k + 3; + i__3 = min(i__4,i__); + for (j = i1; j <= i__3; ++j) { + sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] + + v3 * h__[j + (k + 2) * h_dim1]; + h__[j + k * h_dim1] -= sum * t1; + h__[j + (k + 1) * h_dim1] -= sum * t2; + h__[j + (k + 2) * h_dim1] -= sum * t3; +// L80: + } + if (*wantz) { + // + // Accumulate transformations in the matrix Z + // + i__3 = *ihiz; + for (j = *iloz; j <= i__3; ++j) { + sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * + z_dim1] + v3 * z__[j + (k + 2) * z_dim1]; + z__[j + k * z_dim1] -= sum * t1; + z__[j + (k + 1) * z_dim1] -= sum * t2; + z__[j + (k + 2) * z_dim1] -= sum * t3; +// L90: + } + } + } else if (nr == 2) { + // + // Apply G from the left to transform the rows of the matrix + // in columns K to I2. + // + i__3 = i2; + for (j = k; j <= i__3; ++j) { + sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]; + h__[k + j * h_dim1] -= sum * t1; + h__[k + 1 + j * h_dim1] -= sum * t2; +// L100: + } + // + // Apply G from the right to transform the columns of the + // matrix in rows I1 to min(K+3,I). + // + i__3 = i__; + for (j = i1; j <= i__3; ++j) { + sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] + ; + h__[j + k * h_dim1] -= sum * t1; + h__[j + (k + 1) * h_dim1] -= sum * t2; +// L110: + } + if (*wantz) { + // + // Accumulate transformations in the matrix Z + // + i__3 = *ihiz; + for (j = *iloz; j <= i__3; ++j) { + sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * + z_dim1]; + z__[j + k * z_dim1] -= sum * t1; + z__[j + (k + 1) * z_dim1] -= sum * t2; +// L120: + } + } + } +// L130: + } +// L140: + } + // + // Failure to converge in remaining number of iterations + // + *info = i__; + return 0; +L150: + if (l == i__) { + // + // H(I,I-1) is negligible: one eigenvalue has converged. + // + wr[i__] = h__[i__ + i__ * h_dim1]; + wi[i__] = 0.; + } else if (l == i__ - 1) { + // + // H(I-1,I-2) is negligible: a pair of eigenvalues have converged. + // + // Transform the 2-by-2 submatrix to standard Schur form, + // and compute and store the eigenvalues. + // + dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * + h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * + h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs, + &sn); + if (*wantt) { + // + // Apply the transformation to the rest of H. + // + if (i2 > i__) { + i__1 = i2 - i__; + drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[ + i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn); + } + i__1 = i__ - i1 - 1; + drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ * + h_dim1], &c__1, &cs, &sn); + } + if (*wantz) { + // + // Apply the transformation to Z. + // + drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz + + i__ * z_dim1], &c__1, &cs, &sn); + } + } + // + // return to start of the main loop with new value of I. + // + i__ = l - 1; + goto L20; +L160: + return 0; + // + // End of DLAHQR + // +} // dlahqr_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAHR2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +// +// .. Scalar Arguments .. +// INTEGER K, LDA, LDT, LDY, N, NB +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), +// $ Y( LDY, NB ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) +//> matrix A so that elements below the k-th subdiagonal are zero. The +//> reduction is performed by an orthogonal similarity transformation +//> Q**T * A * Q. The routine returns the matrices V and T which determine +//> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. +//> +//> This is an auxiliary routine called by DGEHRD. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix A. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The offset for the reduction. Elements below the k-th +//> subdiagonal in the first NB columns are reduced to zero. +//> K < N. +//> \endverbatim +//> +//> \param[in] NB +//> \verbatim +//> NB is INTEGER +//> The number of columns to be reduced. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N-K+1) +//> On entry, the n-by-(n-k+1) general matrix A. +//> On exit, the elements on and above the k-th subdiagonal in +//> the first NB columns are overwritten with the corresponding +//> elements of the reduced matrix; the elements below the k-th +//> subdiagonal, with the array TAU, represent the matrix Q as a +//> product of elementary reflectors. The other columns of A are +//> unchanged. See Further Details. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,N). +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (NB) +//> The scalar factors of the elementary reflectors. See Further +//> Details. +//> \endverbatim +//> +//> \param[out] T +//> \verbatim +//> T is DOUBLE PRECISION array, dimension (LDT,NB) +//> The upper triangular matrix T. +//> \endverbatim +//> +//> \param[in] LDT +//> \verbatim +//> LDT is INTEGER +//> The leading dimension of the array T. LDT >= NB. +//> \endverbatim +//> +//> \param[out] Y +//> \verbatim +//> Y is DOUBLE PRECISION array, dimension (LDY,NB) +//> The n-by-nb matrix Y. +//> \endverbatim +//> +//> \param[in] LDY +//> \verbatim +//> LDY is INTEGER +//> The leading dimension of the array Y. LDY >= N. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> The matrix Q is represented as a product of nb elementary reflectors +//> +//> Q = H(1) H(2) . . . H(nb). +//> +//> Each H(i) has the form +//> +//> H(i) = I - tau * v * v**T +//> +//> where tau is a real scalar, and v is a real vector with +//> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in +//> A(i+k+1:n,i), and tau in TAU(i). +//> +//> The elements of the vectors v together form the (n-k+1)-by-nb matrix +//> V which is needed, with T and Y, to apply the transformation to the +//> unreduced part of the matrix, using an update of the form: +//> A := (I - V*T*V**T) * (A - Y*V**T). +//> +//> The contents of A on exit are illustrated by the following example +//> with n = 7, k = 3 and nb = 2: +//> +//> ( a a a a a ) +//> ( a a a a a ) +//> ( a a a a a ) +//> ( h h a a a ) +//> ( v1 h a a a ) +//> ( v1 v2 a a a ) +//> ( v1 v2 a a a ) +//> +//> where a denotes an element of the original matrix A, h denotes a +//> modified element of the upper Hessenberg matrix H, and vi denotes an +//> element of the vector defining H(i). +//> +//> This subroutine is a slight modification of LAPACK-3.0's DLAHRD +//> incorporating improvements proposed by Quintana-Orti and Van de +//> Gejin. Note that the entries of A(1:K,2:NB) differ from those +//> returned by the original LAPACK-3.0's DLAHRD routine. (This +//> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) +//> \endverbatim +// +//> \par References: +// ================ +//> +//> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the +//> performance of reduction to Hessenberg form," ACM Transactions on +//> Mathematical Software, 32(2):180-194, June 2006. +//> +// ===================================================================== +/* Subroutine */ int dlahr2_(int *n, int *k, int *nb, double *a, int *lda, + double *tau, double *t, int *ldt, double *y, int *ldy) +{ + // Table of constant values + double c_b4 = -1.; + double c_b5 = 1.; + int c__1 = 1; + double c_b38 = 0.; + + // System generated locals + int a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + double d__1; + + // Local variables + int i__; + double ei; + extern /* Subroutine */ int dscal_(int *, double *, double *, int *), + dgemm_(char *, char *, int *, int *, int *, double *, double *, + int *, double *, int *, double *, double *, int *), dgemv_(char *, + int *, int *, double *, double *, int *, double *, int *, double + *, double *, int *), dcopy_(int *, double *, int *, double *, int + *), dtrmm_(char *, char *, char *, char *, int *, int *, double *, + double *, int *, double *, int *), daxpy_(int *, double *, + double *, int *, double *, int *), dtrmv_(char *, char *, char *, + int *, double *, int *, double *, int *), dlarfg_(int *, double *, + double *, int *, double *), dlacpy_(char *, int *, int *, double + *, int *, double *, int *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Quick return if possible + // + // Parameter adjustments + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1; + y -= y_offset; + + // Function Body + if (*n <= 1) { + return 0; + } + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ > 1) { + // + // Update A(K+1:N,I) + // + // Update I-th column of A - Y * V**T + // + i__2 = *n - *k; + i__3 = i__ - 1; + dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], + ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 + + i__ * a_dim1], &c__1); + // + // Apply I - V * T**T * V**T to this column (call it b) from the + // left, using the last column of T as workspace + // + // Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) + // ( V2 ) ( b2 ) + // + // where V1 is unit lower triangular + // + // w := V1**T * b1 + // + i__2 = i__ - 1; + dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + dtrmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1); + // + // w := w + V2**T * b2 + // + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * + t_dim1 + 1], &c__1); + // + // w := T**T * w + // + i__2 = i__ - 1; + dtrmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt, + &t[*nb * t_dim1 + 1], &c__1); + // + // b2 := b2 - V2*w + // + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + + i__ * a_dim1], &c__1); + // + // b1 := b1 - V1*w + // + i__2 = i__ - 1; + dtrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1] + , lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ + * a_dim1], &c__1); + a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei; + } + // + // Generate the elementary reflector H(I) to annihilate + // A(K+I+1:N,I) + // + i__2 = *n - *k - i__ + 1; + // Computing MIN + i__3 = *k + i__ + 1; + dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3,*n) + i__ * + a_dim1], &c__1, &tau[i__]); + ei = a[*k + i__ + i__ * a_dim1]; + a[*k + i__ + i__ * a_dim1] = 1.; + // + // Compute Y(K+1:N,I) + // + i__2 = *n - *k; + i__3 = *n - *k - i__ + 1; + dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) * + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[* + k + 1 + i__ * y_dim1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, & + a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + + 1], &c__1); + i__2 = *n - *k; + i__3 = i__ - 1; + dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy, + &t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1], + &c__1); + i__2 = *n - *k; + dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1); + // + // Compute T(1:I,I) + // + i__2 = i__ - 1; + d__1 = -tau[i__]; + dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1); + 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__]; +// L10: + } + a[*k + *nb + *nb * a_dim1] = ei; + // + // Compute Y(1:K,1:NB) + // + dlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy); + dtrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1 + + a_dim1], lda, &y[y_offset], ldy); + if (*n > *k + *nb) { + i__1 = *n - *k - *nb; + dgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb + + 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5, + &y[y_offset], ldy); + } + dtrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[ + t_offset], ldt, &y[y_offset], ldy); + return 0; + // + // End of DLAHR2 + // +} // dlahr2_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLALN2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, +// LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) +// +// .. Scalar Arguments .. +// LOGICAL LTRANS +// INTEGER INFO, LDA, LDB, LDX, NA, NW +// DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLALN2 solves a system of the form (ca A - w D ) X = s B +//> or (ca A**T - w D) X = s B with possible scaling ("s") and +//> perturbation of A. (A**T means A-transpose.) +//> +//> A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA +//> real diagonal matrix, w is a real or complex value, and X and B are +//> NA x 1 matrices -- real if w is real, complex if w is complex. NA +//> may be 1 or 2. +//> +//> If w is complex, X and B are represented as NA x 2 matrices, +//> the first column of each being the real part and the second +//> being the imaginary part. +//> +//> "s" is a scaling factor (<= 1), computed by DLALN2, which is +//> so chosen that X can be computed without overflow. X is further +//> scaled if necessary to assure that norm(ca A - w D)*norm(X) is less +//> than overflow. +//> +//> If both singular values of (ca A - w D) are less than SMIN, +//> SMIN*identity will be used instead of (ca A - w D). If only one +//> singular value is less than SMIN, one element of (ca A - w D) will be +//> perturbed enough to make the smallest singular value roughly SMIN. +//> If both singular values are at least SMIN, (ca A - w D) will not be +//> perturbed. In any case, the perturbation will be at most some small +//> multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values +//> are computed by infinity-norm approximations, and thus will only be +//> correct to a factor of 2 or so. +//> +//> Note: all input quantities are assumed to be smaller than overflow +//> by a reasonable factor. (See BIGNUM.) +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] LTRANS +//> \verbatim +//> LTRANS is LOGICAL +//> =.TRUE.: A-transpose will be used. +//> =.FALSE.: A will be used (not transposed.) +//> \endverbatim +//> +//> \param[in] NA +//> \verbatim +//> NA is INTEGER +//> The size of the matrix A. It may (only) be 1 or 2. +//> \endverbatim +//> +//> \param[in] NW +//> \verbatim +//> NW is INTEGER +//> 1 if "w" is real, 2 if "w" is complex. It may only be 1 +//> or 2. +//> \endverbatim +//> +//> \param[in] SMIN +//> \verbatim +//> SMIN is DOUBLE PRECISION +//> The desired lower bound on the singular values of A. This +//> should be a safe distance away from underflow or overflow, +//> say, between (underflow/machine precision) and (machine +//> precision * overflow ). (See BIGNUM and ULP.) +//> \endverbatim +//> +//> \param[in] CA +//> \verbatim +//> CA is DOUBLE PRECISION +//> The coefficient c, which A is multiplied by. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,NA) +//> The NA x NA matrix A. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of A. It must be at least NA. +//> \endverbatim +//> +//> \param[in] D1 +//> \verbatim +//> D1 is DOUBLE PRECISION +//> The 1,1 element in the diagonal matrix D. +//> \endverbatim +//> +//> \param[in] D2 +//> \verbatim +//> D2 is DOUBLE PRECISION +//> The 2,2 element in the diagonal matrix D. Not used if NA=1. +//> \endverbatim +//> +//> \param[in] B +//> \verbatim +//> B is DOUBLE PRECISION array, dimension (LDB,NW) +//> The NA x NW matrix B (right-hand side). If NW=2 ("w" is +//> complex), column 1 contains the real part of B and column 2 +//> contains the imaginary part. +//> \endverbatim +//> +//> \param[in] LDB +//> \verbatim +//> LDB is INTEGER +//> The leading dimension of B. It must be at least NA. +//> \endverbatim +//> +//> \param[in] WR +//> \verbatim +//> WR is DOUBLE PRECISION +//> The real part of the scalar "w". +//> \endverbatim +//> +//> \param[in] WI +//> \verbatim +//> WI is DOUBLE PRECISION +//> The imaginary part of the scalar "w". Not used if NW=1. +//> \endverbatim +//> +//> \param[out] X +//> \verbatim +//> X is DOUBLE PRECISION array, dimension (LDX,NW) +//> The NA x NW matrix X (unknowns), as computed by DLALN2. +//> If NW=2 ("w" is complex), on exit, column 1 will contain +//> the real part of X and column 2 will contain the imaginary +//> part. +//> \endverbatim +//> +//> \param[in] LDX +//> \verbatim +//> LDX is INTEGER +//> The leading dimension of X. It must be at least NA. +//> \endverbatim +//> +//> \param[out] SCALE +//> \verbatim +//> SCALE is DOUBLE PRECISION +//> The scale factor that B must be multiplied by to insure +//> that overflow does not occur when computing X. Thus, +//> (ca A - w D) X will be SCALE*B, not B (ignoring +//> perturbations of A.) It will be at most 1. +//> \endverbatim +//> +//> \param[out] XNORM +//> \verbatim +//> XNORM is DOUBLE PRECISION +//> The infinity-norm of X, when X is regarded as an NA x NW +//> real matrix. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> An error flag. It will be set to zero if no error occurs, +//> a negative number if an argument is in error, or a positive +//> number if ca A - w D had to be perturbed. +//> The possible values are: +//> = 0: No error occurred, and (ca A - w D) did not have to be +//> perturbed. +//> = 1: (ca A - w D) had to be perturbed to make its smallest +//> (or only) singular value greater than SMIN. +//> NOTE: In the interests of speed, this routine does not +//> check the inputs for errors. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlaln2_(int *ltrans, int *na, int *nw, double *smin, + double *ca, double *a, int *lda, double *d1, double *d2, double *b, + int *ldb, double *wr, double *wi, double *x, int *ldx, double *scale, + double *xnorm, int *info) +{ + /* Initialized data */ + + static int zswap[4] = { FALSE_,FALSE_,TRUE_,TRUE_ }; + static int rswap[4] = { FALSE_,TRUE_,FALSE_,TRUE_ }; + static int ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2, + 4,3,2,1 }; + + // System generated locals + int a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset; + double d__1, d__2, d__3, d__4, d__5, d__6; + static double equiv_0[4], equiv_1[4]; + + // Local variables + int j; +#define ci (equiv_0) +#define cr (equiv_1) + double bi1, bi2, br1, br2, xi1, xi2, xr1, xr2, ci21, ci22, cr21, cr22, + li21, csi, ui11, lr21, ui12, ui22; +#define civ (equiv_0) + double csr, ur11, ur12, ur22; +#define crv (equiv_1) + double bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s, u22abs; + int icmax; + double bnorm, cnorm, smini; + extern double dlamch_(char *); + extern /* Subroutine */ int dladiv_(double *, double *, double *, double * + , double *, double *); + double bignum, smlnum; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + //===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. Local Arrays .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Equivalences .. + // .. + // .. Data 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; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + + // Function Body + // .. + // .. Executable Statements .. + // + // Compute BIGNUM + // + smlnum = 2. * dlamch_("Safe minimum"); + bignum = 1. / smlnum; + smini = max(*smin,smlnum); + // + // Don't check for input errors + // + *info = 0; + // + // Standard Initializations + // + *scale = 1.; + if (*na == 1) { + // + // 1 x 1 (i.e., scalar) system C X = B + // + if (*nw == 1) { + // + // Real 1x1 system. + // + // C = ca A - w D + // + csr = *ca * a[a_dim1 + 1] - *wr * *d1; + cnorm = abs(csr); + // + // If | C | < SMINI, use C = SMINI + // + if (cnorm < smini) { + csr = smini; + cnorm = smini; + *info = 1; + } + // + // Check scaling for X = B / C + // + bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)); + if (cnorm < 1. && bnorm > 1.) { + if (bnorm > bignum * cnorm) { + *scale = 1. / bnorm; + } + } + // + // Compute X + // + x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr; + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)); + } else { + // + // Complex 1x1 system (w is complex) + // + // C = ca A - w D + // + csr = *ca * a[a_dim1 + 1] - *wr * *d1; + csi = -(*wi) * *d1; + cnorm = abs(csr) + abs(csi); + // + // If | C | < SMINI, use C = SMINI + // + if (cnorm < smini) { + csr = smini; + csi = 0.; + cnorm = smini; + *info = 1; + } + // + // Check scaling for X = B / C + // + bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << + 1) + 1], abs(d__2)); + if (cnorm < 1. && bnorm > 1.) { + if (bnorm > bignum * cnorm) { + *scale = 1. / bnorm; + } + } + // + // Compute X + // + d__1 = *scale * b[b_dim1 + 1]; + d__2 = *scale * b[(b_dim1 << 1) + 1]; + dladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1) + + 1]); + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << + 1) + 1], abs(d__2)); + } + } else { + // + // 2x2 System + // + // Compute the real part of C = ca A - w D (or ca A**T - w D ) + // + cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1; + cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2; + if (*ltrans) { + cr[2] = *ca * a[a_dim1 + 2]; + cr[1] = *ca * a[(a_dim1 << 1) + 1]; + } else { + cr[1] = *ca * a[a_dim1 + 2]; + cr[2] = *ca * a[(a_dim1 << 1) + 1]; + } + if (*nw == 1) { + // + // Real 2x2 system (w is real) + // + // Find the largest element in C + // + cmax = 0.; + icmax = 0; + for (j = 1; j <= 4; ++j) { + if ((d__1 = crv[j - 1], abs(d__1)) > cmax) { + cmax = (d__1 = crv[j - 1], abs(d__1)); + icmax = j; + } +// L10: + } + // + // If norm(C) < SMINI, use SMINI*identity. + // + if (cmax < smini) { + // Computing MAX + d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[ + b_dim1 + 2], abs(d__2)); + bnorm = max(d__3,d__4); + if (smini < 1. && bnorm > 1.) { + if (bnorm > bignum * smini) { + *scale = 1. / bnorm; + } + } + temp = *scale / smini; + x[x_dim1 + 1] = temp * b[b_dim1 + 1]; + x[x_dim1 + 2] = temp * b[b_dim1 + 2]; + *xnorm = temp * bnorm; + *info = 1; + return 0; + } + // + // Gaussian elimination with complete pivoting. + // + ur11 = crv[icmax - 1]; + cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; + ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; + cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; + ur11r = 1. / ur11; + lr21 = ur11r * cr21; + ur22 = cr22 - ur12 * lr21; + // + // If smaller pivot < SMINI, use SMINI + // + if (abs(ur22) < smini) { + ur22 = smini; + *info = 1; + } + if (rswap[icmax - 1]) { + br1 = b[b_dim1 + 2]; + br2 = b[b_dim1 + 1]; + } else { + br1 = b[b_dim1 + 1]; + br2 = b[b_dim1 + 2]; + } + br2 -= lr21 * br1; + // Computing MAX + d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2); + bbnd = max(d__2,d__3); + if (bbnd > 1. && abs(ur22) < 1.) { + if (bbnd >= bignum * abs(ur22)) { + *scale = 1. / bbnd; + } + } + xr2 = br2 * *scale / ur22; + xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12); + if (zswap[icmax - 1]) { + x[x_dim1 + 1] = xr2; + x[x_dim1 + 2] = xr1; + } else { + x[x_dim1 + 1] = xr1; + x[x_dim1 + 2] = xr2; + } + // Computing MAX + d__1 = abs(xr1), d__2 = abs(xr2); + *xnorm = max(d__1,d__2); + // + // Further scaling if norm(A) norm(X) > overflow + // + if (*xnorm > 1. && cmax > 1.) { + if (*xnorm > bignum / cmax) { + temp = cmax / bignum; + x[x_dim1 + 1] = temp * x[x_dim1 + 1]; + x[x_dim1 + 2] = temp * x[x_dim1 + 2]; + *xnorm = temp * *xnorm; + *scale = temp * *scale; + } + } + } else { + // + // Complex 2x2 system (w is complex) + // + // Find the largest element in C + // + ci[0] = -(*wi) * *d1; + ci[1] = 0.; + ci[2] = 0.; + ci[3] = -(*wi) * *d2; + cmax = 0.; + icmax = 0; + for (j = 1; j <= 4; ++j) { + if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs( + d__2)) > cmax) { + cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1] + , abs(d__2)); + icmax = j; + } +// L20: + } + // + // If norm(C) < SMINI, use SMINI*identity. + // + if (cmax < smini) { + // Computing MAX + d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 + << 1) + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], + abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4)); + bnorm = max(d__5,d__6); + if (smini < 1. && bnorm > 1.) { + if (bnorm > bignum * smini) { + *scale = 1. / bnorm; + } + } + temp = *scale / smini; + x[x_dim1 + 1] = temp * b[b_dim1 + 1]; + x[x_dim1 + 2] = temp * b[b_dim1 + 2]; + x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1]; + x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2]; + *xnorm = temp * bnorm; + *info = 1; + return 0; + } + // + // Gaussian elimination with complete pivoting. + // + ur11 = crv[icmax - 1]; + ui11 = civ[icmax - 1]; + cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; + ci21 = civ[ipivot[(icmax << 2) - 3] - 1]; + ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; + ui12 = civ[ipivot[(icmax << 2) - 2] - 1]; + cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; + ci22 = civ[ipivot[(icmax << 2) - 1] - 1]; + if (icmax == 1 || icmax == 4) { + // + // Code when off-diagonals of pivoted C are real + // + if (abs(ur11) > abs(ui11)) { + temp = ui11 / ur11; + // Computing 2nd power + d__1 = temp; + ur11r = 1. / (ur11 * (d__1 * d__1 + 1.)); + ui11r = -temp * ur11r; + } else { + temp = ur11 / ui11; + // Computing 2nd power + d__1 = temp; + ui11r = -1. / (ui11 * (d__1 * d__1 + 1.)); + ur11r = -temp * ui11r; + } + lr21 = cr21 * ur11r; + li21 = cr21 * ui11r; + ur12s = ur12 * ur11r; + ui12s = ur12 * ui11r; + ur22 = cr22 - ur12 * lr21; + ui22 = ci22 - ur12 * li21; + } else { + // + // Code when diagonals of pivoted C are real + // + ur11r = 1. / ur11; + ui11r = 0.; + lr21 = cr21 * ur11r; + li21 = ci21 * ur11r; + ur12s = ur12 * ur11r; + ui12s = ui12 * ur11r; + ur22 = cr22 - ur12 * lr21 + ui12 * li21; + ui22 = -ur12 * li21 - ui12 * lr21; + } + u22abs = abs(ur22) + abs(ui22); + // + // If smaller pivot < SMINI, use SMINI + // + if (u22abs < smini) { + ur22 = smini; + ui22 = 0.; + *info = 1; + } + if (rswap[icmax - 1]) { + br2 = b[b_dim1 + 1]; + br1 = b[b_dim1 + 2]; + bi2 = b[(b_dim1 << 1) + 1]; + bi1 = b[(b_dim1 << 1) + 2]; + } else { + br1 = b[b_dim1 + 1]; + br2 = b[b_dim1 + 2]; + bi1 = b[(b_dim1 << 1) + 1]; + bi2 = b[(b_dim1 << 1) + 2]; + } + br2 = br2 - lr21 * br1 + li21 * bi1; + bi2 = bi2 - li21 * br1 - lr21 * bi1; + // Computing MAX + d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r)) + ), d__2 = abs(br2) + abs(bi2); + bbnd = max(d__1,d__2); + if (bbnd > 1. && u22abs < 1.) { + if (bbnd >= bignum * u22abs) { + *scale = 1. / bbnd; + br1 = *scale * br1; + bi1 = *scale * bi1; + br2 = *scale * br2; + bi2 = *scale * bi2; + } + } + dladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2); + xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2; + xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2; + if (zswap[icmax - 1]) { + x[x_dim1 + 1] = xr2; + x[x_dim1 + 2] = xr1; + x[(x_dim1 << 1) + 1] = xi2; + x[(x_dim1 << 1) + 2] = xi1; + } else { + x[x_dim1 + 1] = xr1; + x[x_dim1 + 2] = xr2; + x[(x_dim1 << 1) + 1] = xi1; + x[(x_dim1 << 1) + 2] = xi2; + } + // Computing MAX + d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2); + *xnorm = max(d__1,d__2); + // + // Further scaling if norm(A) norm(X) > overflow + // + if (*xnorm > 1. && cmax > 1.) { + if (*xnorm > bignum / cmax) { + temp = cmax / bignum; + x[x_dim1 + 1] = temp * x[x_dim1 + 1]; + x[x_dim1 + 2] = temp * x[x_dim1 + 2]; + x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1]; + x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2]; + *xnorm = temp * *xnorm; + *scale = temp * *scale; + } + } + } + } + return 0; + // + // End of DLALN2 + // +} // dlaln2_ + +#undef crv +#undef civ +#undef cr +#undef ci + + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLANV2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric +//> matrix in standard form: +//> +//> [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] +//> [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] +//> +//> where either +//> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or +//> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex +//> conjugate eigenvalues. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] B +//> \verbatim +//> B is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is DOUBLE PRECISION +//> On entry, the elements of the input matrix. +//> On exit, they are overwritten by the elements of the +//> standardised Schur form. +//> \endverbatim +//> +//> \param[out] RT1R +//> \verbatim +//> RT1R is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[out] RT1I +//> \verbatim +//> RT1I is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[out] RT2R +//> \verbatim +//> RT2R is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[out] RT2I +//> \verbatim +//> RT2I is DOUBLE PRECISION +//> The real and imaginary parts of the eigenvalues. If the +//> eigenvalues are a complex conjugate pair, RT1I > 0. +//> \endverbatim +//> +//> \param[out] CS +//> \verbatim +//> CS is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[out] SN +//> \verbatim +//> SN is DOUBLE PRECISION +//> Parameters of the rotation matrix. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> Modified by V. Sima, Research Institute for Informatics, Bucharest, +//> Romania, to reduce the risk of cancellation errors, +//> when computing real eigenvalues, and to ensure, if possible, that +//> abs(RT1R) >= abs(RT2R). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlanv2_(double *a, double *b, double *c__, double *d__, + double *rt1r, double *rt1i, double *rt2r, double *rt2i, double *cs, + double *sn) +{ + // Table of constant values + double c_b3 = 1.; + + // System generated locals + double d__1, d__2; + + // Local variables + double p, z__, aa, bb, cc, dd, cs1, sn1, sab, sac, eps, tau, temp, scale, + bcmax, bcmis, sigma; + extern double dlapy2_(double *, double *), dlamch_(char *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + eps = dlamch_("P"); + if (*c__ == 0.) { + *cs = 1.; + *sn = 0.; + } else if (*b == 0.) { + // + // Swap rows and columns + // + *cs = 0.; + *sn = 1.; + temp = *d__; + *d__ = *a; + *a = temp; + *b = -(*c__); + *c__ = 0.; + } else if (*a - *d__ == 0. && d_sign(&c_b3, b) != d_sign(&c_b3, c__)) { + *cs = 1.; + *sn = 0.; + } else { + temp = *a - *d__; + p = temp * .5; + // Computing MAX + d__1 = abs(*b), d__2 = abs(*c__); + bcmax = max(d__1,d__2); + // Computing MIN + d__1 = abs(*b), d__2 = abs(*c__); + bcmis = min(d__1,d__2) * d_sign(&c_b3, b) * d_sign(&c_b3, c__); + // Computing MAX + d__1 = abs(p); + scale = max(d__1,bcmax); + z__ = p / scale * p + bcmax / scale * bcmis; + // + // If Z is of the order of the machine accuracy, postpone the + // decision on the nature of eigenvalues + // + if (z__ >= eps * 4.) { + // + // Real eigenvalues. Compute A and D. + // + d__1 = sqrt(scale) * sqrt(z__); + z__ = p + d_sign(&d__1, &p); + *a = *d__ + z__; + *d__ -= bcmax / z__ * bcmis; + // + // Compute B and the rotation matrix + // + tau = dlapy2_(c__, &z__); + *cs = z__ / tau; + *sn = *c__ / tau; + *b -= *c__; + *c__ = 0.; + } else { + // + // Complex eigenvalues, or real (almost) equal eigenvalues. + // Make diagonal elements equal. + // + sigma = *b + *c__; + tau = dlapy2_(&sigma, &temp); + *cs = sqrt((abs(sigma) / tau + 1.) * .5); + *sn = -(p / (tau * *cs)) * d_sign(&c_b3, &sigma); + // + // Compute [ AA BB ] = [ A B ] [ CS -SN ] + // [ CC DD ] [ C D ] [ SN CS ] + // + aa = *a * *cs + *b * *sn; + bb = -(*a) * *sn + *b * *cs; + cc = *c__ * *cs + *d__ * *sn; + dd = -(*c__) * *sn + *d__ * *cs; + // + // Compute [ A B ] = [ CS SN ] [ AA BB ] + // [ C D ] [-SN CS ] [ CC DD ] + // + *a = aa * *cs + cc * *sn; + *b = bb * *cs + dd * *sn; + *c__ = -aa * *sn + cc * *cs; + *d__ = -bb * *sn + dd * *cs; + temp = (*a + *d__) * .5; + *a = temp; + *d__ = temp; + if (*c__ != 0.) { + if (*b != 0.) { + if (d_sign(&c_b3, b) == d_sign(&c_b3, c__)) { + // + // Real eigenvalues: reduce to upper triangular form + // + sab = sqrt((abs(*b))); + sac = sqrt((abs(*c__))); + d__1 = sab * sac; + p = d_sign(&d__1, c__); + tau = 1. / sqrt((d__1 = *b + *c__, abs(d__1))); + *a = temp + p; + *d__ = temp - p; + *b -= *c__; + *c__ = 0.; + cs1 = sab * tau; + sn1 = sac * tau; + temp = *cs * cs1 - *sn * sn1; + *sn = *cs * sn1 + *sn * cs1; + *cs = temp; + } + } else { + *b = -(*c__); + *c__ = 0.; + temp = *cs; + *cs = -(*sn); + *sn = temp; + } + } + } + } + // + // Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). + // + *rt1r = *a; + *rt2r = *d__; + if (*c__ == 0.) { + *rt1i = 0.; + *rt2i = 0.; + } else { + *rt1i = sqrt((abs(*b))) * sqrt((abs(*c__))); + *rt2i = -(*rt1i); + } + return 0; + // + // End of DLANV2 + // +} // dlanv2_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAQR0 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +// ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N +// LOGICAL WANTT, WANTZ +// .. +// .. Array Arguments .. +// DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), +// $ Z( LDZ, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLAQR0 computes the eigenvalues of a Hessenberg matrix H +//> and, optionally, the matrices T and Z from the Schur decomposition +//> H = Z T Z**T, where T is an upper quasi-triangular matrix (the +//> Schur form), and Z is the orthogonal matrix of Schur vectors. +//> +//> Optionally Z may be postmultiplied into an input orthogonal +//> matrix Q so that this routine can give the Schur factorization +//> of a matrix A which has been reduced to the Hessenberg form H +//> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] WANTT +//> \verbatim +//> WANTT is LOGICAL +//> = .TRUE. : the full Schur form T is required; +//> = .FALSE.: only eigenvalues are required. +//> \endverbatim +//> +//> \param[in] WANTZ +//> \verbatim +//> WANTZ is LOGICAL +//> = .TRUE. : the matrix of Schur vectors Z is required; +//> = .FALSE.: Schur vectors are not required. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix H. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> It is assumed that H is already upper triangular in rows +//> and columns 1:ILO-1 and IHI+1:N and, if ILO > 1, +//> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +//> previous call to DGEBAL, and then passed to DGEHRD when the +//> matrix output by DGEBAL is reduced to Hessenberg form. +//> Otherwise, ILO and IHI should be set to 1 and N, +//> respectively. If N > 0, then 1 <= ILO <= IHI <= N. +//> If N = 0, then ILO = 1 and IHI = 0. +//> \endverbatim +//> +//> \param[in,out] H +//> \verbatim +//> H is DOUBLE PRECISION array, dimension (LDH,N) +//> On entry, the upper Hessenberg matrix H. +//> On exit, if INFO = 0 and WANTT is .TRUE., then H contains +//> the upper quasi-triangular matrix T from the Schur +//> decomposition (the Schur form); 2-by-2 diagonal blocks +//> (corresponding to complex conjugate pairs of eigenvalues) +//> are returned in standard form, with H(i,i) = H(i+1,i+1) +//> and H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and WANTT is +//> .FALSE., then the contents of H are unspecified on exit. +//> (The output value of H when INFO > 0 is given under the +//> description of INFO below.) +//> +//> This subroutine may explicitly set H(i,j) = 0 for i > j and +//> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. +//> \endverbatim +//> +//> \param[in] LDH +//> \verbatim +//> LDH is INTEGER +//> The leading dimension of the array H. LDH >= max(1,N). +//> \endverbatim +//> +//> \param[out] WR +//> \verbatim +//> WR is DOUBLE PRECISION array, dimension (IHI) +//> \endverbatim +//> +//> \param[out] WI +//> \verbatim +//> WI is DOUBLE PRECISION array, dimension (IHI) +//> The real and imaginary parts, respectively, of the computed +//> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) +//> and WI(ILO:IHI). If two eigenvalues are computed as a +//> complex conjugate pair, they are stored in consecutive +//> elements of WR and WI, say the i-th and (i+1)th, with +//> WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., then +//> the eigenvalues are stored in the same order as on the +//> diagonal of the Schur form returned in H, with +//> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal +//> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +//> WI(i+1) = -WI(i). +//> \endverbatim +//> +//> \param[in] ILOZ +//> \verbatim +//> ILOZ is INTEGER +//> \endverbatim +//> +//> \param[in] IHIZ +//> \verbatim +//> IHIZ is INTEGER +//> Specify the rows of Z to which transformations must be +//> applied if WANTZ is .TRUE.. +//> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) +//> If WANTZ is .FALSE., then Z is not referenced. +//> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +//> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +//> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +//> (The output value of Z when INFO > 0 is given under +//> the description of INFO below.) +//> \endverbatim +//> +//> \param[in] LDZ +//> \verbatim +//> LDZ is INTEGER +//> The leading dimension of the array Z. if WANTZ is .TRUE. +//> then LDZ >= MAX(1,IHIZ). Otherwise, LDZ >= 1. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension LWORK +//> On exit, if LWORK = -1, WORK(1) returns an estimate of +//> the optimal value for LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the array WORK. LWORK >= max(1,N) +//> is sufficient, but LWORK typically as large as 6*N may +//> be required for optimal performance. A workspace query +//> to determine the optimal workspace size is recommended. +//> +//> If LWORK = -1, then DLAQR0 does a workspace query. +//> In this case, DLAQR0 checks the input parameters and +//> estimates the optimal workspace size for the given +//> values of N, ILO and IHI. The estimate is returned +//> in WORK(1). No error message related to LWORK is +//> issued by XERBLA. Neither H nor Z are accessed. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> > 0: if INFO = i, DLAQR0 failed to compute all of +//> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +//> and WI contain those eigenvalues which have been +//> successfully computed. (Failures are rare.) +//> +//> If INFO > 0 and WANT is .FALSE., then on exit, +//> the remaining unconverged eigenvalues are the eigen- +//> values of the upper Hessenberg matrix rows and +//> columns ILO through INFO of the final, output +//> value of H. +//> +//> If INFO > 0 and WANTT is .TRUE., then on exit +//> +//> (*) (initial value of H)*U = U*(final value of H) +//> +//> where U is an orthogonal matrix. The final +//> value of H is upper Hessenberg and quasi-triangular +//> in rows and columns INFO+1 through IHI. +//> +//> If INFO > 0 and WANTZ is .TRUE., then on exit +//> +//> (final value of Z(ILO:IHI,ILOZ:IHIZ) +//> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +//> +//> where U is the orthogonal matrix in (*) (regard- +//> less of the value of WANTT.) +//> +//> If INFO > 0 and WANTZ is .FALSE., then Z is not +//> accessed. +//> \endverbatim +// +//> \par Contributors: +// ================== +//> +//> Karen Braman and Ralph Byers, Department of Mathematics, +//> University of Kansas, USA +// +//> \par References: +// ================ +//> +//> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +//> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +//> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +//> 929--947, 2002. +//> \n +//> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +//> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +//> of Matrix Analysis, volume 23, pages 948--973, 2002. +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlaqr0_(int *wantt, int *wantz, int *n, int *ilo, int * + ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int * + ihiz, double *z__, int *ldz, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__13 = 13; + int c__15 = 15; + int c_n1 = -1; + int c__12 = 12; + int c__14 = 14; + int c__16 = 16; + int c_false = FALSE_; + int c__1 = 1; + int c__3 = 3; + + // System generated locals + int h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2, d__3, d__4; + + // Local variables + int i__, k; + double aa, bb, cc, dd; + int ld; + double cs; + int nh, it, ks, kt; + double sn; + int ku, kv, ls, ns; + double ss; + int nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; + double swap; + int ktop; + double zdum[1] /* was [1][1] */; + int kacc22, itmax, nsmax, nwmax, kwtop; + extern /* Subroutine */ int dlanv2_(double *, double *, double *, double * + , double *, double *, double *, double *, double *, double *), + dlaqr3_(int *, int *, int *, int *, int *, int *, double *, int *, + int *, int *, double *, int *, int *, int *, double *, double *, + double *, int *, int *, double *, int *, int *, double *, int *, + double *, int *), dlaqr4_(int *, int *, int *, int *, int *, + double *, int *, double *, double *, int *, int *, double *, int * + , double *, int *, int *), dlaqr5_(int *, int *, int *, int *, + int *, int *, int *, double *, double *, double *, int *, int *, + int *, double *, int *, double *, int *, double *, int *, int *, + double *, int *, int *, double *, int *); + int nibble; + extern /* Subroutine */ int dlahqr_(int *, int *, int *, int *, int *, + double *, int *, double *, double *, int *, int *, double *, int * + , int *), dlacpy_(char *, int *, int *, double *, int *, double *, + int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + char jbcmpz[2+1]={'\0'}; + int nwupbd; + int sorted; + int lwkopt; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ================================================================ + // + // .. Parameters .. + // + // ==== Matrices of order NTINY or smaller must be processed by + // . DLAHQR because of insufficient subdiagonal scratch space. + // . (This is a hard limit.) ==== + // + // ==== Exceptional deflation windows: try to cure rare + // . slow convergence by varying the size of the + // . deflation window after KEXNW iterations. ==== + // + // ==== Exceptional shifts: try to cure rare slow convergence + // . with ad-hoc exceptional shifts every KEXSH iterations. + // . ==== + // + // ==== The constants WILK1 and WILK2 are used to form the + // . exceptional shifts. ==== + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Local Arrays .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // Parameter adjustments + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + // Function Body + *info = 0; + // + // ==== Quick return for N = 0: nothing to do. ==== + // + if (*n == 0) { + work[1] = 1.; + return 0; + } + if (*n <= 11) { + // + // ==== Tiny matrices must use DLAHQR. ==== + // + lwkopt = 1; + if (*lwork != -1) { + dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & + wi[1], iloz, ihiz, &z__[z_offset], ldz, info); + } + } else { + // + // ==== Use small bulge multi-shift QR with aggressive early + // . deflation on larger-than-tiny matrices. ==== + // + // ==== Hope for the best. ==== + // + *info = 0; + // + // ==== Set up job flags for ILAENV. ==== + // + if (*wantt) { + *(unsigned char *)jbcmpz = 'S'; + } else { + *(unsigned char *)jbcmpz = 'E'; + } + if (*wantz) { + *(unsigned char *)&jbcmpz[1] = 'V'; + } else { + *(unsigned char *)&jbcmpz[1] = 'N'; + } + // + // ==== NWR = recommended deflation window size. At this + // . point, N .GT. NTINY = 11, so there is enough + // . subdiagonal workspace for NWR.GE.2 as required. + // . (In fact, there is enough subdiagonal space for + // . NWR.GE.3.) ==== + // + nwr = ilaenv_(&c__13, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + nwr = max(2,nwr); + // Computing MIN + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2); + nwr = min(i__1,nwr); + // + // ==== NSR = recommended number of simultaneous shifts. + // . At this point N .GT. NTINY = 11, so there is at + // . enough subdiagonal workspace for NSR to be even + // . and greater than or equal to two as required. ==== + // + nsr = ilaenv_(&c__15, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + // Computing MIN + i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi - + *ilo; + nsr = min(i__1,i__2); + // Computing MAX + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = max(i__1,i__2); + // + // ==== Estimate optimal workspace ==== + // + // ==== Workspace query call to DLAQR3 ==== + // + i__1 = nwr + 1; + dlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, + ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ + h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], + ldh, &work[1], &c_n1); + // + // ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== + // + // Computing MAX + i__1 = nsr * 3 / 2, i__2 = (int) work[1]; + lwkopt = max(i__1,i__2); + // + // ==== Quick return in case of workspace query. ==== + // + if (*lwork == -1) { + work[1] = (double) lwkopt; + return 0; + } + // + // ==== DLAHQR/DLAQR0 crossover point ==== + // + nmin = ilaenv_(&c__12, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + nmin = max(11,nmin); + // + // ==== Nibble crossover point ==== + // + nibble = ilaenv_(&c__14, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + nibble = max(0,nibble); + // + // ==== Accumulate reflections during ttswp? Use block + // . 2-by-2 structure during matrix-matrix multiply? ==== + // + kacc22 = ilaenv_(&c__16, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + kacc22 = max(0,kacc22); + kacc22 = min(2,kacc22); + // + // ==== NWMAX = the largest possible deflation window for + // . which there is sufficient workspace. ==== + // + // Computing MIN + i__1 = (*n - 1) / 3, i__2 = *lwork / 2; + nwmax = min(i__1,i__2); + nw = nwmax; + // + // ==== NSMAX = the Largest number of simultaneous shifts + // . for which there is sufficient workspace. ==== + // + // Computing MIN + i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3; + nsmax = min(i__1,i__2); + nsmax -= nsmax % 2; + // + // ==== NDFL: an iteration count restarted at deflation. ==== + // + ndfl = 1; + // + // ==== ITMAX = iteration limit ==== + // + // Computing MAX + i__1 = 10, i__2 = *ihi - *ilo + 1; + itmax = max(i__1,i__2) * 30; + // + // ==== Last row and column in the active block ==== + // + kbot = *ihi; + // + // ==== Main Loop ==== + // + i__1 = itmax; + for (it = 1; it <= i__1; ++it) { + // + // ==== Done when KBOT falls below ILO ==== + // + if (kbot < *ilo) { + goto L90; + } + // + // ==== Locate active block ==== + // + i__2 = *ilo + 1; + for (k = kbot; k >= i__2; --k) { + if (h__[k + (k - 1) * h_dim1] == 0.) { + goto L20; + } +// L10: + } + k = *ilo; +L20: + ktop = k; + // + // ==== Select deflation window size: + // . Typical Case: + // . If possible and advisable, nibble the entire + // . active block. If not, use size MIN(NWR,NWMAX) + // . or MIN(NWR+1,NWMAX) depending upon which has + // . the smaller corresponding subdiagonal entry + // . (a heuristic). + // . + // . Exceptional Case: + // . If there have been no deflations in KEXNW or + // . more iterations, then vary the deflation window + // . size. At first, because, larger windows are, + // . in general, more powerful than smaller ones, + // . rapidly increase the window to the maximum possible. + // . Then, gradually reduce the window size. ==== + // + nh = kbot - ktop + 1; + nwupbd = min(nh,nwmax); + if (ndfl < 5) { + nw = min(nwupbd,nwr); + } else { + // Computing MIN + i__2 = nwupbd, i__3 = nw << 1; + nw = min(i__2,i__3); + } + if (nw < nwmax) { + if (nw >= nh - 1) { + nw = nh; + } else { + kwtop = kbot - nw + 1; + if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) + > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], + abs(d__2))) { + ++nw; + } + } + } + if (ndfl < 5) { + ndec = -1; + } else if (ndec >= 0 || nw >= nwupbd) { + ++ndec; + if (nw - ndec < 2) { + ndec = 0; + } + nw -= ndec; + } + // + // ==== Aggressive early deflation: + // . split workspace under the subdiagonal into + // . - an nw-by-nw work array V in the lower + // . left-hand-corner, + // . - an NW-by-at-least-NW-but-more-is-better + // . (NW-by-NHO) horizontal work array along + // . the bottom edge, + // . - an at-least-NW-but-more-is-better (NHV-by-NW) + // . vertical work array along the left-hand-edge. + // . ==== + // + kv = *n - nw + 1; + kt = nw + 1; + nho = *n - nw - 1 - kt + 1; + kwv = nw + 2; + nve = *n - nw - kwv + 1; + // + // ==== Aggressive early deflation ==== + // + dlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, + iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], + &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); + // + // ==== Adjust KBOT accounting for new deflations. ==== + // + kbot -= ld; + // + // ==== KS points to the shifts. ==== + // + ks = kbot - ls + 1; + // + // ==== Skip an expensive QR sweep if there is a (partly + // . heuristic) reason to expect that many eigenvalues + // . will deflate without it. Here, the QR sweep is + // . skipped if many eigenvalues have just been deflated + // . or if the remaining active block is small. + // + if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min( + nmin,nwmax)) { + // + // ==== NS = nominal number of simultaneous shifts. + // . This may be lowered (slightly) if DLAQR3 + // . did not provide that many shifts. ==== + // + // Computing MIN + // Computing MAX + i__4 = 2, i__5 = kbot - ktop; + i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5); + ns = min(i__2,i__3); + ns -= ns % 2; + // + // ==== If there have been no deflations + // . in a multiple of KEXSH iterations, + // . then try exceptional shifts. + // . Otherwise use shifts provided by + // . DLAQR3 above or from the eigenvalues + // . of a trailing principal submatrix. ==== + // + if (ndfl % 6 == 0) { + ks = kbot - ns + 1; + // Computing MAX + i__3 = ks + 1, i__4 = ktop + 2; + i__2 = max(i__3,i__4); + for (i__ = kbot; i__ >= i__2; i__ += -2) { + ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], + abs(d__2)); + aa = ss * .75 + h__[i__ + i__ * h_dim1]; + bb = ss; + cc = ss * -.4375; + dd = aa; + dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] + , &wr[i__], &wi[i__], &cs, &sn); +// L30: + } + if (ks == ktop) { + wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; + wi[ks + 1] = 0.; + wr[ks] = wr[ks + 1]; + wi[ks] = wi[ks + 1]; + } + } else { + // + // ==== Got NS/2 or fewer shifts? Use DLAQR4 or + // . DLAHQR on a trailing principal submatrix to + // . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, + // . there is enough space below the subdiagonal + // . to fit an NS-by-NS scratch array.) ==== + // + if (kbot - ks + 1 <= ns / 2) { + ks = kbot - ns + 1; + kt = *n - ns + 1; + dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & + h__[kt + h_dim1], ldh); + if (ns > nmin) { + dlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ + kt + h_dim1], ldh, &wr[ks], &wi[ks], & + c__1, &c__1, zdum, &c__1, &work[1], lwork, + &inf); + } else { + dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ + kt + h_dim1], ldh, &wr[ks], &wi[ks], & + c__1, &c__1, zdum, &c__1, &inf); + } + ks += inf; + // + // ==== In case of a rare QR failure use + // . eigenvalues of the trailing 2-by-2 + // . principal submatrix. ==== + // + if (ks >= kbot) { + aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; + cc = h__[kbot + (kbot - 1) * h_dim1]; + bb = h__[kbot - 1 + kbot * h_dim1]; + dd = h__[kbot + kbot * h_dim1]; + dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ + kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) + ; + ks = kbot - 1; + } + } + if (kbot - ks + 1 > ns) { + // + // ==== Sort the shifts (Helps a little) + // . Bubble sort keeps complex conjugate + // . pairs together. ==== + // + sorted = FALSE_; + i__2 = ks + 1; + for (k = kbot; k >= i__2; --k) { + if (sorted) { + goto L60; + } + sorted = TRUE_; + i__3 = k - 1; + for (i__ = ks; i__ <= i__3; ++i__) { + if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[ + i__], abs(d__2)) < (d__3 = wr[i__ + 1] + , abs(d__3)) + (d__4 = wi[i__ + 1], + abs(d__4))) { + sorted = FALSE_; + swap = wr[i__]; + wr[i__] = wr[i__ + 1]; + wr[i__ + 1] = swap; + swap = wi[i__]; + wi[i__] = wi[i__ + 1]; + wi[i__ + 1] = swap; + } +// L40: + } +// L50: + } +L60: + ; + } + // + // ==== Shuffle shifts into pairs of real shifts + // . and pairs of complex conjugate shifts + // . assuming complex conjugate shifts are + // . already adjacent to one another. (Yes, + // . they are.) ==== + // + i__2 = ks + 2; + for (i__ = kbot; i__ >= i__2; i__ += -2) { + if (wi[i__] != -wi[i__ - 1]) { + swap = wr[i__]; + wr[i__] = wr[i__ - 1]; + wr[i__ - 1] = wr[i__ - 2]; + wr[i__ - 2] = swap; + swap = wi[i__]; + wi[i__] = wi[i__ - 1]; + wi[i__ - 1] = wi[i__ - 2]; + wi[i__ - 2] = swap; + } +// L70: + } + } + // + // ==== If there are only two shifts and both are + // . real, then use only one. ==== + // + if (kbot - ks + 1 == 2) { + if (wi[kbot] == 0.) { + if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs( + d__1)) < (d__2 = wr[kbot - 1] - h__[kbot + + kbot * h_dim1], abs(d__2))) { + wr[kbot - 1] = wr[kbot]; + } else { + wr[kbot] = wr[kbot - 1]; + } + } + } + // + // ==== Use up to NS of the the smallest magnitude + // . shifts. If there aren't NS shifts available, + // . then use them all, possibly dropping one to + // . make the number of shifts even. ==== + // + // Computing MIN + i__2 = ns, i__3 = kbot - ks + 1; + ns = min(i__2,i__3); + ns -= ns % 2; + ks = kbot - ns + 1; + // + // ==== Small-bulge multi-shift QR sweep: + // . split workspace under the subdiagonal into + // . - a KDU-by-KDU work array U in the lower + // . left-hand-corner, + // . - a KDU-by-at-least-KDU-but-more-is-better + // . (KDU-by-NHo) horizontal work array WH along + // . the bottom edge, + // . - and an at-least-KDU-but-more-is-better-by-KDU + // . (NVE-by-KDU) vertical work WV arrow along + // . the left-hand-edge. ==== + // + kdu = ns * 3 - 3; + ku = *n - kdu + 1; + kwh = kdu + 1; + nho = *n - kdu - 3 - (kdu + 1) + 1; + kwv = kdu + 4; + nve = *n - kdu - kwv + 1; + // + // ==== Small-bulge multi-shift QR sweep ==== + // + dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], + &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ + z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + + kwh * h_dim1], ldh); + } + // + // ==== Note progress (or the lack of it). ==== + // + if (ld > 0) { + ndfl = 1; + } else { + ++ndfl; + } + // + // ==== End of main loop ==== +// L80: + } + // + // ==== Iteration limit exceeded. Set INFO to show where + // . the problem occurred and exit. ==== + // + *info = kbot; +L90: + ; + } + // + // ==== Return the optimal value of LWORK. ==== + // + work[1] = (double) lwkopt; + // + // ==== End of DLAQR0 ==== + // + return 0; +} // dlaqr0_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAQR1 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION SI1, SI2, SR1, SR2 +// INTEGER LDH, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION H( LDH, * ), V( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a +//> scalar multiple of the first column of the product +//> +//> (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) +//> +//> scaling to avoid overflows and most underflows. It +//> is assumed that either +//> +//> 1) sr1 = sr2 and si1 = -si2 +//> or +//> 2) si1 = si2 = 0. +//> +//> This is useful for starting double implicit shift bulges +//> in the QR algorithm. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> Order of the matrix H. N must be either 2 or 3. +//> \endverbatim +//> +//> \param[in] H +//> \verbatim +//> H is DOUBLE PRECISION array, dimension (LDH,N) +//> The 2-by-2 or 3-by-3 matrix H in (*). +//> \endverbatim +//> +//> \param[in] LDH +//> \verbatim +//> LDH is INTEGER +//> The leading dimension of H as declared in +//> the calling procedure. LDH >= N +//> \endverbatim +//> +//> \param[in] SR1 +//> \verbatim +//> SR1 is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] SI1 +//> \verbatim +//> SI1 is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] SR2 +//> \verbatim +//> SR2 is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] SI2 +//> \verbatim +//> SI2 is DOUBLE PRECISION +//> The shifts in (*). +//> \endverbatim +//> +//> \param[out] V +//> \verbatim +//> V is DOUBLE PRECISION array, dimension (N) +//> A scalar multiple of the first column of the +//> matrix K in (*). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Karen Braman and Ralph Byers, Department of Mathematics, +//> University of Kansas, USA +//> +// ===================================================================== +/* Subroutine */ int dlaqr1_(int *n, double *h__, int *ldh, double *sr1, + double *si1, double *sr2, double *si2, double *v) +{ + // System generated locals + int h_dim1, h_offset; + double d__1, d__2, d__3; + + // Local variables + double s, h21s, h31s; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ================================================================ + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Quick return if possible + // + // Parameter adjustments + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --v; + + // Function Body + if (*n != 2 && *n != 3) { + return 0; + } + if (*n == 2) { + s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) + (d__2 = + h__[h_dim1 + 2], abs(d__2)); + if (s == 0.) { + v[1] = 0.; + v[2] = 0.; + } else { + h21s = h__[h_dim1 + 2] / s; + v[1] = h21s * h__[(h_dim1 << 1) + 1] + (h__[h_dim1 + 1] - *sr1) * + ((h__[h_dim1 + 1] - *sr2) / s) - *si1 * (*si2 / s); + v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - * + sr2); + } + } else { + s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) + (d__2 = + h__[h_dim1 + 2], abs(d__2)) + (d__3 = h__[h_dim1 + 3], abs( + d__3)); + if (s == 0.) { + v[1] = 0.; + v[2] = 0.; + v[3] = 0.; + } else { + h21s = h__[h_dim1 + 2] / s; + h31s = h__[h_dim1 + 3] / s; + v[1] = (h__[h_dim1 + 1] - *sr1) * ((h__[h_dim1 + 1] - *sr2) / s) + - *si1 * (*si2 / s) + h__[(h_dim1 << 1) + 1] * h21s + h__[ + h_dim1 * 3 + 1] * h31s; + v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - * + sr2) + h__[h_dim1 * 3 + 2] * h31s; + v[3] = h31s * (h__[h_dim1 + 1] + h__[h_dim1 * 3 + 3] - *sr1 - * + sr2) + h21s * h__[(h_dim1 << 1) + 3]; + } + } + return 0; +} // dlaqr1_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAQR2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +// IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, +// LDT, NV, WV, LDWV, WORK, LWORK ) +// +// .. Scalar Arguments .. +// INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +// $ LDZ, LWORK, N, ND, NH, NS, NV, NW +// LOGICAL WANTT, WANTZ +// .. +// .. Array Arguments .. +// DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), +// $ V( LDV, * ), WORK( * ), WV( LDWV, * ), +// $ Z( LDZ, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLAQR2 is identical to DLAQR3 except that it avoids +//> recursion by calling DLAHQR instead of DLAQR4. +//> +//> Aggressive early deflation: +//> +//> This subroutine accepts as input an upper Hessenberg matrix +//> H and performs an orthogonal similarity transformation +//> designed to detect and deflate fully converged eigenvalues from +//> a trailing principal submatrix. On output H has been over- +//> written by a new Hessenberg matrix that is a perturbation of +//> an orthogonal similarity transformation of H. It is to be +//> hoped that the final version of H has many zero subdiagonal +//> entries. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] WANTT +//> \verbatim +//> WANTT is LOGICAL +//> If .TRUE., then the Hessenberg matrix H is fully updated +//> so that the quasi-triangular Schur factor may be +//> computed (in cooperation with the calling subroutine). +//> If .FALSE., then only enough of H is updated to preserve +//> the eigenvalues. +//> \endverbatim +//> +//> \param[in] WANTZ +//> \verbatim +//> WANTZ is LOGICAL +//> If .TRUE., then the orthogonal matrix Z is updated so +//> so that the orthogonal Schur factor may be computed +//> (in cooperation with the calling subroutine). +//> If .FALSE., then Z is not referenced. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix H and (if WANTZ is .TRUE.) the +//> order of the orthogonal matrix Z. +//> \endverbatim +//> +//> \param[in] KTOP +//> \verbatim +//> KTOP is INTEGER +//> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +//> KBOT and KTOP together determine an isolated block +//> along the diagonal of the Hessenberg matrix. +//> \endverbatim +//> +//> \param[in] KBOT +//> \verbatim +//> KBOT is INTEGER +//> It is assumed without a check that either +//> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +//> determine an isolated block along the diagonal of the +//> Hessenberg matrix. +//> \endverbatim +//> +//> \param[in] NW +//> \verbatim +//> NW is INTEGER +//> Deflation window size. 1 <= NW <= (KBOT-KTOP+1). +//> \endverbatim +//> +//> \param[in,out] H +//> \verbatim +//> H is DOUBLE PRECISION array, dimension (LDH,N) +//> On input the initial N-by-N section of H stores the +//> Hessenberg matrix undergoing aggressive early deflation. +//> On output H has been transformed by an orthogonal +//> similarity transformation, perturbed, and the returned +//> to Hessenberg form that (it is to be hoped) has some +//> zero subdiagonal entries. +//> \endverbatim +//> +//> \param[in] LDH +//> \verbatim +//> LDH is INTEGER +//> Leading dimension of H just as declared in the calling +//> subroutine. N <= LDH +//> \endverbatim +//> +//> \param[in] ILOZ +//> \verbatim +//> ILOZ is INTEGER +//> \endverbatim +//> +//> \param[in] IHIZ +//> \verbatim +//> IHIZ is INTEGER +//> Specify the rows of Z to which transformations must be +//> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (LDZ,N) +//> IF WANTZ is .TRUE., then on output, the orthogonal +//> similarity transformation mentioned above has been +//> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +//> If WANTZ is .FALSE., then Z is unreferenced. +//> \endverbatim +//> +//> \param[in] LDZ +//> \verbatim +//> LDZ is INTEGER +//> The leading dimension of Z just as declared in the +//> calling subroutine. 1 <= LDZ. +//> \endverbatim +//> +//> \param[out] NS +//> \verbatim +//> NS is INTEGER +//> The number of unconverged (ie approximate) eigenvalues +//> returned in SR and SI that may be used as shifts by the +//> calling subroutine. +//> \endverbatim +//> +//> \param[out] ND +//> \verbatim +//> ND is INTEGER +//> The number of converged eigenvalues uncovered by this +//> subroutine. +//> \endverbatim +//> +//> \param[out] SR +//> \verbatim +//> SR is DOUBLE PRECISION array, dimension (KBOT) +//> \endverbatim +//> +//> \param[out] SI +//> \verbatim +//> SI is DOUBLE PRECISION array, dimension (KBOT) +//> On output, the real and imaginary parts of approximate +//> eigenvalues that may be used for shifts are stored in +//> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +//> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +//> The real and imaginary parts of converged eigenvalues +//> are stored in SR(KBOT-ND+1) through SR(KBOT) and +//> SI(KBOT-ND+1) through SI(KBOT), respectively. +//> \endverbatim +//> +//> \param[out] V +//> \verbatim +//> V is DOUBLE PRECISION array, dimension (LDV,NW) +//> An NW-by-NW work array. +//> \endverbatim +//> +//> \param[in] LDV +//> \verbatim +//> LDV is INTEGER +//> The leading dimension of V just as declared in the +//> calling subroutine. NW <= LDV +//> \endverbatim +//> +//> \param[in] NH +//> \verbatim +//> NH is INTEGER +//> The number of columns of T. NH >= NW. +//> \endverbatim +//> +//> \param[out] T +//> \verbatim +//> T is DOUBLE PRECISION array, dimension (LDT,NW) +//> \endverbatim +//> +//> \param[in] LDT +//> \verbatim +//> LDT is INTEGER +//> The leading dimension of T just as declared in the +//> calling subroutine. NW <= LDT +//> \endverbatim +//> +//> \param[in] NV +//> \verbatim +//> NV is INTEGER +//> The number of rows of work array WV available for +//> workspace. NV >= NW. +//> \endverbatim +//> +//> \param[out] WV +//> \verbatim +//> WV is DOUBLE PRECISION array, dimension (LDWV,NW) +//> \endverbatim +//> +//> \param[in] LDWV +//> \verbatim +//> LDWV is INTEGER +//> The leading dimension of W just as declared in the +//> calling subroutine. NW <= LDV +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (LWORK) +//> On exit, WORK(1) is set to an estimate of the optimal value +//> of LWORK for the given values of N, NW, KTOP and KBOT. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the work array WORK. LWORK = 2*NW +//> suffices, but greater efficiency may result from larger +//> values of LWORK. +//> +//> If LWORK = -1, then a workspace query is assumed; DLAQR2 +//> only estimates the optimal workspace size for the given +//> values of N, NW, KTOP and KBOT. The estimate is returned +//> in WORK(1). No error message related to LWORK is issued +//> by XERBLA. Neither H nor Z are accessed. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Karen Braman and Ralph Byers, Department of Mathematics, +//> University of Kansas, USA +//> +// ===================================================================== +/* Subroutine */ int dlaqr2_(int *wantt, int *wantz, int *n, int *ktop, int * + kbot, int *nw, double *h__, int *ldh, int *iloz, int *ihiz, double * + z__, int *ldz, int *ns, int *nd, double *sr, double *si, double *v, + int *ldv, int *nh, double *t, int *ldt, int *nv, double *wv, int * + ldwv, double *work, int *lwork) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + double c_b12 = 0.; + double c_b13 = 1.; + int c_true = TRUE_; + + // System generated locals + int h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, + wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4, d__5, d__6; + + // Local variables + int i__, j, k; + double s, aa, bb, cc, dd, cs, sn; + int jw; + double evi, evk, foo; + int kln; + double tau, ulp; + int lwk1, lwk2; + double beta; + int kend, kcol, info, ifst, ilst, ltop, krow; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *), dgemm_(char *, char *, int * + , int *, int *, double *, double *, int *, double *, int *, + double *, double *, int *); + int bulge; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + int infqr, kwtop; + extern /* Subroutine */ int dlanv2_(double *, double *, double *, double * + , double *, double *, double *, double *, double *, double *), + dlabad_(double *, double *); + extern double dlamch_(char *); + extern /* Subroutine */ int dgehrd_(int *, int *, int *, double *, int *, + double *, double *, int *, int *), dlarfg_(int *, double *, + double *, int *, double *), dlahqr_(int *, int *, int *, int *, + int *, double *, int *, double *, double *, int *, int *, double * + , int *, int *), dlacpy_(char *, int *, int *, double *, int *, + double *, int *); + double safmin; + extern /* Subroutine */ int dlaset_(char *, int *, int *, double *, + double *, double *, int *); + double safmax; + extern /* Subroutine */ int dtrexc_(char *, int *, double *, int *, + double *, int *, int *, int *, double *, int *), dormhr_(char *, + char *, int *, int *, int *, int *, double *, int *, double *, + double *, int *, double *, int *, int *); + int sorted; + double smlnum; + int lwkopt; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ================================================================ + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // ==== Estimate optimal workspace. ==== + // + // Parameter adjustments + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --sr; + --si; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1; + wv -= wv_offset; + --work; + + // Function Body + // Computing MIN + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = min(i__1,i__2); + if (jw <= 2) { + lwkopt = 1; + } else { + // + // ==== Workspace query call to DGEHRD ==== + // + i__1 = jw - 1; + dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & + c_n1, &info); + lwk1 = (int) work[1]; + // + // ==== Workspace query call to DORMHR ==== + // + i__1 = jw - 1; + dormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[1], &c_n1, &info); + lwk2 = (int) work[1]; + // + // ==== Optimal workspace ==== + // + lwkopt = jw + max(lwk1,lwk2); + } + // + // ==== Quick return in case of workspace query. ==== + // + if (*lwork == -1) { + work[1] = (double) lwkopt; + return 0; + } + // + // ==== Nothing to do ... + // ... for an empty active block ... ==== + *ns = 0; + *nd = 0; + work[1] = 1.; + if (*ktop > *kbot) { + return 0; + } + // ... nor for an empty deflation window. ==== + if (*nw < 1) { + return 0; + } + // + // ==== Machine constants ==== + // + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((double) (*n) / ulp); + // + // ==== Setup deflation window ==== + // + // Computing MIN + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = min(i__1,i__2); + kwtop = *kbot - jw + 1; + if (kwtop == *ktop) { + s = 0.; + } else { + s = h__[kwtop + (kwtop - 1) * h_dim1]; + } + if (*kbot == kwtop) { + // + // ==== 1-by-1 deflation window: not much to do ==== + // + sr[kwtop] = h__[kwtop + kwtop * h_dim1]; + si[kwtop] = 0.; + *ns = 1; + *nd = 0; + // Computing MAX + d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs( + d__1)); + if (abs(s) <= max(d__2,d__3)) { + *ns = 0; + *nd = 1; + if (kwtop > *ktop) { + h__[kwtop + (kwtop - 1) * h_dim1] = 0.; + } + } + work[1] = 1.; + return 0; + } + // + // ==== Convert to spike-triangular form. (In case of a + // . rare QR failure, this routine continues to do + // . aggressive early deflation using that part of + // . the deflation window that converged using INFQR + // . here and there to keep track.) ==== + // + dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], + ldt); + i__1 = jw - 1; + i__2 = *ldh + 1; + i__3 = *ldt + 1; + dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & + i__3); + dlaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv); + dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], + &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); + // + // ==== DTREXC needs a clean margin near the diagonal ==== + // + i__1 = jw - 3; + for (j = 1; j <= i__1; ++j) { + t[j + 2 + j * t_dim1] = 0.; + t[j + 3 + j * t_dim1] = 0.; +// L10: + } + if (jw > 2) { + t[jw + (jw - 2) * t_dim1] = 0.; + } + // + // ==== Deflation detection loop ==== + // + *ns = jw; + ilst = infqr + 1; +L20: + if (ilst <= *ns) { + if (*ns == 1) { + bulge = FALSE_; + } else { + bulge = t[*ns + (*ns - 1) * t_dim1] != 0.; + } + // + // ==== Small spike tip test for deflation ==== + // + if (! bulge) { + // + // ==== Real eigenvalue ==== + // + foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1)); + if (foo == 0.) { + foo = abs(s); + } + // Computing MAX + d__2 = smlnum, d__3 = ulp * foo; + if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2,d__3)) + { + // + // ==== Deflatable ==== + // + --(*ns); + } else { + // + // ==== Undeflatable. Move it up out of the way. + // . (DTREXC can not fail in this case.) ==== + // + ifst = *ns; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ++ilst; + } + } else { + // + // ==== Complex conjugate pair ==== + // + foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[* + ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[* + ns - 1 + *ns * t_dim1], abs(d__2))); + if (foo == 0.) { + foo = abs(s); + } + // Computing MAX + d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 = + s * v[(*ns - 1) * v_dim1 + 1], abs(d__2)); + // Computing MAX + d__5 = smlnum, d__6 = ulp * foo; + if (max(d__3,d__4) <= max(d__5,d__6)) { + // + // ==== Deflatable ==== + // + *ns += -2; + } else { + // + // ==== Undeflatable. Move them up out of the way. + // . Fortunately, DTREXC does the right thing with + // . ILST in case of a rare exchange failure. ==== + // + ifst = *ns; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ilst += 2; + } + } + // + // ==== End deflation detection loop ==== + // + goto L20; + } + // + // ==== Return to Hessenberg form ==== + // + if (*ns == 0) { + s = 0.; + } + if (*ns < jw) { + // + // ==== sorting diagonal blocks of T improves accuracy for + // . graded matrices. Bubble sort deals well with + // . exchange failures. ==== + // + sorted = FALSE_; + i__ = *ns + 1; +L30: + if (sorted) { + goto L50; + } + sorted = TRUE_; + kend = i__ - 1; + i__ = infqr + 1; + if (i__ == *ns) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { + k = i__ + 1; + } else { + k = i__ + 2; + } +L40: + if (k <= kend) { + if (k == i__ + 1) { + evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1)); + } else { + evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 = + t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 = + t[i__ + (i__ + 1) * t_dim1], abs(d__2))); + } + if (k == kend) { + evk = (d__1 = t[k + k * t_dim1], abs(d__1)); + } else if (t[k + 1 + k * t_dim1] == 0.) { + evk = (d__1 = t[k + k * t_dim1], abs(d__1)); + } else { + evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[ + k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k + + (k + 1) * t_dim1], abs(d__2))); + } + if (evi >= evk) { + i__ = k; + } else { + sorted = FALSE_; + ifst = i__; + ilst = k; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + if (info == 0) { + i__ = ilst; + } else { + i__ = k; + } + } + if (i__ == kend) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { + k = i__ + 1; + } else { + k = i__ + 2; + } + goto L40; + } + goto L30; +L50: + ; + } + // + // ==== Restore shift/eigenvalue array from T ==== + // + i__ = jw; +L60: + if (i__ >= infqr + 1) { + if (i__ == infqr + 1) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.; + --i__; + } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.; + --i__; + } else { + aa = t[i__ - 1 + (i__ - 1) * t_dim1]; + cc = t[i__ + (i__ - 1) * t_dim1]; + bb = t[i__ - 1 + i__ * t_dim1]; + dd = t[i__ + i__ * t_dim1]; + dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ + - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & + sn); + i__ += -2; + } + goto L60; + } + if (*ns < jw || s == 0.) { + if (*ns > 1 && s != 0.) { + // + // ==== Reflect spike back into lower triangle ==== + // + dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); + beta = work[1]; + dlarfg_(ns, &beta, &work[2], &c__1, &tau); + work[1] = 1.; + i__1 = jw - 2; + i__2 = jw - 2; + dlaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt); + dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & + work[jw + 1]); + i__1 = *lwork - jw; + dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] + , &i__1, &info); + } + // + // ==== Copy updated reduced window into place ==== + // + if (kwtop > 1) { + h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; + } + dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] + , ldh); + i__1 = jw - 1; + i__2 = *ldt + 1; + i__3 = *ldh + 1; + dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], + &i__3); + // + // ==== Accumulate orthogonal matrix in order update + // . H and Z, if requested. ==== + // + if (*ns > 1 && s != 0.) { + i__1 = *lwork - jw; + dormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[jw + 1], &i__1, &info); + } + // + // ==== Update vertical slab in H ==== + // + if (*wantt) { + ltop = 1; + } else { + ltop = *ktop; + } + i__1 = kwtop - 1; + i__2 = *nv; + for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { + // Computing MIN + i__3 = *nv, i__4 = kwtop - krow; + kln = min(i__3,i__4); + dgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * + h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], + ldwv); + dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * + h_dim1], ldh); +// L70: + } + // + // ==== Update horizontal slab in H ==== + // + if (*wantt) { + i__2 = *n; + i__1 = *nh; + for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; + kcol += i__1) { + // Computing MIN + i__3 = *nh, i__4 = *n - kcol + 1; + kln = min(i__3,i__4); + dgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & + h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], + ldt); + dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * + h_dim1], ldh); +// L80: + } + } + // + // ==== Update vertical slab in Z ==== + // + if (*wantz) { + i__1 = *ihiz; + i__2 = *nv; + for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { + // Computing MIN + i__3 = *nv, i__4 = *ihiz - krow + 1; + kln = min(i__3,i__4); + dgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * + z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ + wv_offset], ldwv); + dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + + kwtop * z_dim1], ldz); +// L90: + } + } + } + // + // ==== Return the number of deflations ... ==== + // + *nd = jw - *ns; + // + // ==== ... and the number of shifts. (Subtracting + // . INFQR from the spike length takes care + // . of the case of a rare QR failure while + // . calculating eigenvalues of the deflation + // . window.) ==== + // + *ns -= infqr; + // + // ==== Return optimal workspace. ==== + // + work[1] = (double) lwkopt; + // + // ==== End of DLAQR2 ==== + // + return 0; +} // dlaqr2_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAQR3 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +// IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, +// LDT, NV, WV, LDWV, WORK, LWORK ) +// +// .. Scalar Arguments .. +// INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +// $ LDZ, LWORK, N, ND, NH, NS, NV, NW +// LOGICAL WANTT, WANTZ +// .. +// .. Array Arguments .. +// DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), +// $ V( LDV, * ), WORK( * ), WV( LDWV, * ), +// $ Z( LDZ, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> Aggressive early deflation: +//> +//> DLAQR3 accepts as input an upper Hessenberg matrix +//> H and performs an orthogonal similarity transformation +//> designed to detect and deflate fully converged eigenvalues from +//> a trailing principal submatrix. On output H has been over- +//> written by a new Hessenberg matrix that is a perturbation of +//> an orthogonal similarity transformation of H. It is to be +//> hoped that the final version of H has many zero subdiagonal +//> entries. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] WANTT +//> \verbatim +//> WANTT is LOGICAL +//> If .TRUE., then the Hessenberg matrix H is fully updated +//> so that the quasi-triangular Schur factor may be +//> computed (in cooperation with the calling subroutine). +//> If .FALSE., then only enough of H is updated to preserve +//> the eigenvalues. +//> \endverbatim +//> +//> \param[in] WANTZ +//> \verbatim +//> WANTZ is LOGICAL +//> If .TRUE., then the orthogonal matrix Z is updated so +//> so that the orthogonal Schur factor may be computed +//> (in cooperation with the calling subroutine). +//> If .FALSE., then Z is not referenced. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix H and (if WANTZ is .TRUE.) the +//> order of the orthogonal matrix Z. +//> \endverbatim +//> +//> \param[in] KTOP +//> \verbatim +//> KTOP is INTEGER +//> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +//> KBOT and KTOP together determine an isolated block +//> along the diagonal of the Hessenberg matrix. +//> \endverbatim +//> +//> \param[in] KBOT +//> \verbatim +//> KBOT is INTEGER +//> It is assumed without a check that either +//> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +//> determine an isolated block along the diagonal of the +//> Hessenberg matrix. +//> \endverbatim +//> +//> \param[in] NW +//> \verbatim +//> NW is INTEGER +//> Deflation window size. 1 <= NW <= (KBOT-KTOP+1). +//> \endverbatim +//> +//> \param[in,out] H +//> \verbatim +//> H is DOUBLE PRECISION array, dimension (LDH,N) +//> On input the initial N-by-N section of H stores the +//> Hessenberg matrix undergoing aggressive early deflation. +//> On output H has been transformed by an orthogonal +//> similarity transformation, perturbed, and the returned +//> to Hessenberg form that (it is to be hoped) has some +//> zero subdiagonal entries. +//> \endverbatim +//> +//> \param[in] LDH +//> \verbatim +//> LDH is INTEGER +//> Leading dimension of H just as declared in the calling +//> subroutine. N <= LDH +//> \endverbatim +//> +//> \param[in] ILOZ +//> \verbatim +//> ILOZ is INTEGER +//> \endverbatim +//> +//> \param[in] IHIZ +//> \verbatim +//> IHIZ is INTEGER +//> Specify the rows of Z to which transformations must be +//> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (LDZ,N) +//> IF WANTZ is .TRUE., then on output, the orthogonal +//> similarity transformation mentioned above has been +//> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +//> If WANTZ is .FALSE., then Z is unreferenced. +//> \endverbatim +//> +//> \param[in] LDZ +//> \verbatim +//> LDZ is INTEGER +//> The leading dimension of Z just as declared in the +//> calling subroutine. 1 <= LDZ. +//> \endverbatim +//> +//> \param[out] NS +//> \verbatim +//> NS is INTEGER +//> The number of unconverged (ie approximate) eigenvalues +//> returned in SR and SI that may be used as shifts by the +//> calling subroutine. +//> \endverbatim +//> +//> \param[out] ND +//> \verbatim +//> ND is INTEGER +//> The number of converged eigenvalues uncovered by this +//> subroutine. +//> \endverbatim +//> +//> \param[out] SR +//> \verbatim +//> SR is DOUBLE PRECISION array, dimension (KBOT) +//> \endverbatim +//> +//> \param[out] SI +//> \verbatim +//> SI is DOUBLE PRECISION array, dimension (KBOT) +//> On output, the real and imaginary parts of approximate +//> eigenvalues that may be used for shifts are stored in +//> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +//> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +//> The real and imaginary parts of converged eigenvalues +//> are stored in SR(KBOT-ND+1) through SR(KBOT) and +//> SI(KBOT-ND+1) through SI(KBOT), respectively. +//> \endverbatim +//> +//> \param[out] V +//> \verbatim +//> V is DOUBLE PRECISION array, dimension (LDV,NW) +//> An NW-by-NW work array. +//> \endverbatim +//> +//> \param[in] LDV +//> \verbatim +//> LDV is INTEGER +//> The leading dimension of V just as declared in the +//> calling subroutine. NW <= LDV +//> \endverbatim +//> +//> \param[in] NH +//> \verbatim +//> NH is INTEGER +//> The number of columns of T. NH >= NW. +//> \endverbatim +//> +//> \param[out] T +//> \verbatim +//> T is DOUBLE PRECISION array, dimension (LDT,NW) +//> \endverbatim +//> +//> \param[in] LDT +//> \verbatim +//> LDT is INTEGER +//> The leading dimension of T just as declared in the +//> calling subroutine. NW <= LDT +//> \endverbatim +//> +//> \param[in] NV +//> \verbatim +//> NV is INTEGER +//> The number of rows of work array WV available for +//> workspace. NV >= NW. +//> \endverbatim +//> +//> \param[out] WV +//> \verbatim +//> WV is DOUBLE PRECISION array, dimension (LDWV,NW) +//> \endverbatim +//> +//> \param[in] LDWV +//> \verbatim +//> LDWV is INTEGER +//> The leading dimension of W just as declared in the +//> calling subroutine. NW <= LDV +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (LWORK) +//> On exit, WORK(1) is set to an estimate of the optimal value +//> of LWORK for the given values of N, NW, KTOP and KBOT. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the work array WORK. LWORK = 2*NW +//> suffices, but greater efficiency may result from larger +//> values of LWORK. +//> +//> If LWORK = -1, then a workspace query is assumed; DLAQR3 +//> only estimates the optimal workspace size for the given +//> values of N, NW, KTOP and KBOT. The estimate is returned +//> in WORK(1). No error message related to LWORK is issued +//> by XERBLA. Neither H nor Z are accessed. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Karen Braman and Ralph Byers, Department of Mathematics, +//> University of Kansas, USA +//> +// ===================================================================== +/* Subroutine */ int dlaqr3_(int *wantt, int *wantz, int *n, int *ktop, int * + kbot, int *nw, double *h__, int *ldh, int *iloz, int *ihiz, double * + z__, int *ldz, int *ns, int *nd, double *sr, double *si, double *v, + int *ldv, int *nh, double *t, int *ldt, int *nv, double *wv, int * + ldwv, double *work, int *lwork) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c_true = TRUE_; + double c_b17 = 0.; + double c_b18 = 1.; + int c__12 = 12; + + // System generated locals + int h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, + wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4, d__5, d__6; + + // Local variables + int i__, j, k; + double s, aa, bb, cc, dd, cs, sn; + int jw; + double evi, evk, foo; + int kln; + double tau, ulp; + int lwk1, lwk2, lwk3; + double beta; + int kend, kcol, info, nmin, ifst, ilst, ltop, krow; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *), dgemm_(char *, char *, int * + , int *, int *, double *, double *, int *, double *, int *, + double *, double *, int *); + int bulge; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + int infqr, kwtop; + extern /* Subroutine */ int dlanv2_(double *, double *, double *, double * + , double *, double *, double *, double *, double *, double *), + dlaqr4_(int *, int *, int *, int *, int *, double *, int *, + double *, double *, int *, int *, double *, int *, double *, int * + , int *), dlabad_(double *, double *); + extern double dlamch_(char *); + extern /* Subroutine */ int dgehrd_(int *, int *, int *, double *, int *, + double *, double *, int *, int *), dlarfg_(int *, double *, + double *, int *, double *), dlahqr_(int *, int *, int *, int *, + int *, double *, int *, double *, double *, int *, int *, double * + , int *, int *), dlacpy_(char *, int *, int *, double *, int *, + double *, int *); + double safmin; + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + double safmax; + extern /* Subroutine */ int dlaset_(char *, int *, int *, double *, + double *, double *, int *), dtrexc_(char *, int *, double *, int * + , double *, int *, int *, int *, double *, int *), dormhr_(char *, + char *, int *, int *, int *, int *, double *, int *, double *, + double *, int *, double *, int *, int *); + int sorted; + double smlnum; + int lwkopt; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ================================================================ + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // ==== Estimate optimal workspace. ==== + // + // Parameter adjustments + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --sr; + --si; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1; + wv -= wv_offset; + --work; + + // Function Body + // Computing MIN + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = min(i__1,i__2); + if (jw <= 2) { + lwkopt = 1; + } else { + // + // ==== Workspace query call to DGEHRD ==== + // + i__1 = jw - 1; + dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & + c_n1, &info); + lwk1 = (int) work[1]; + // + // ==== Workspace query call to DORMHR ==== + // + i__1 = jw - 1; + dormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[1], &c_n1, &info); + lwk2 = (int) work[1]; + // + // ==== Workspace query call to DLAQR4 ==== + // + dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[1], + &si[1], &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, & + infqr); + lwk3 = (int) work[1]; + // + // ==== Optimal workspace ==== + // + // Computing MAX + i__1 = jw + max(lwk1,lwk2); + lwkopt = max(i__1,lwk3); + } + // + // ==== Quick return in case of workspace query. ==== + // + if (*lwork == -1) { + work[1] = (double) lwkopt; + return 0; + } + // + // ==== Nothing to do ... + // ... for an empty active block ... ==== + *ns = 0; + *nd = 0; + work[1] = 1.; + if (*ktop > *kbot) { + return 0; + } + // ... nor for an empty deflation window. ==== + if (*nw < 1) { + return 0; + } + // + // ==== Machine constants ==== + // + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((double) (*n) / ulp); + // + // ==== Setup deflation window ==== + // + // Computing MIN + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = min(i__1,i__2); + kwtop = *kbot - jw + 1; + if (kwtop == *ktop) { + s = 0.; + } else { + s = h__[kwtop + (kwtop - 1) * h_dim1]; + } + if (*kbot == kwtop) { + // + // ==== 1-by-1 deflation window: not much to do ==== + // + sr[kwtop] = h__[kwtop + kwtop * h_dim1]; + si[kwtop] = 0.; + *ns = 1; + *nd = 0; + // Computing MAX + d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs( + d__1)); + if (abs(s) <= max(d__2,d__3)) { + *ns = 0; + *nd = 1; + if (kwtop > *ktop) { + h__[kwtop + (kwtop - 1) * h_dim1] = 0.; + } + } + work[1] = 1.; + return 0; + } + // + // ==== Convert to spike-triangular form. (In case of a + // . rare QR failure, this routine continues to do + // . aggressive early deflation using that part of + // . the deflation window that converged using INFQR + // . here and there to keep track.) ==== + // + dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], + ldt); + i__1 = jw - 1; + i__2 = *ldh + 1; + i__3 = *ldt + 1; + dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & + i__3); + dlaset_("A", &jw, &jw, &c_b17, &c_b18, &v[v_offset], ldv); + nmin = ilaenv_(&c__12, "DLAQR3", "SV", &jw, &c__1, &jw, lwork); + if (jw > nmin) { + dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[ + kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], + lwork, &infqr); + } else { + dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[ + kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); + } + // + // ==== DTREXC needs a clean margin near the diagonal ==== + // + i__1 = jw - 3; + for (j = 1; j <= i__1; ++j) { + t[j + 2 + j * t_dim1] = 0.; + t[j + 3 + j * t_dim1] = 0.; +// L10: + } + if (jw > 2) { + t[jw + (jw - 2) * t_dim1] = 0.; + } + // + // ==== Deflation detection loop ==== + // + *ns = jw; + ilst = infqr + 1; +L20: + if (ilst <= *ns) { + if (*ns == 1) { + bulge = FALSE_; + } else { + bulge = t[*ns + (*ns - 1) * t_dim1] != 0.; + } + // + // ==== Small spike tip test for deflation ==== + // + if (! bulge) { + // + // ==== Real eigenvalue ==== + // + foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1)); + if (foo == 0.) { + foo = abs(s); + } + // Computing MAX + d__2 = smlnum, d__3 = ulp * foo; + if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2,d__3)) + { + // + // ==== Deflatable ==== + // + --(*ns); + } else { + // + // ==== Undeflatable. Move it up out of the way. + // . (DTREXC can not fail in this case.) ==== + // + ifst = *ns; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ++ilst; + } + } else { + // + // ==== Complex conjugate pair ==== + // + foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[* + ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[* + ns - 1 + *ns * t_dim1], abs(d__2))); + if (foo == 0.) { + foo = abs(s); + } + // Computing MAX + d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 = + s * v[(*ns - 1) * v_dim1 + 1], abs(d__2)); + // Computing MAX + d__5 = smlnum, d__6 = ulp * foo; + if (max(d__3,d__4) <= max(d__5,d__6)) { + // + // ==== Deflatable ==== + // + *ns += -2; + } else { + // + // ==== Undeflatable. Move them up out of the way. + // . Fortunately, DTREXC does the right thing with + // . ILST in case of a rare exchange failure. ==== + // + ifst = *ns; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ilst += 2; + } + } + // + // ==== End deflation detection loop ==== + // + goto L20; + } + // + // ==== Return to Hessenberg form ==== + // + if (*ns == 0) { + s = 0.; + } + if (*ns < jw) { + // + // ==== sorting diagonal blocks of T improves accuracy for + // . graded matrices. Bubble sort deals well with + // . exchange failures. ==== + // + sorted = FALSE_; + i__ = *ns + 1; +L30: + if (sorted) { + goto L50; + } + sorted = TRUE_; + kend = i__ - 1; + i__ = infqr + 1; + if (i__ == *ns) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { + k = i__ + 1; + } else { + k = i__ + 2; + } +L40: + if (k <= kend) { + if (k == i__ + 1) { + evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1)); + } else { + evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 = + t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 = + t[i__ + (i__ + 1) * t_dim1], abs(d__2))); + } + if (k == kend) { + evk = (d__1 = t[k + k * t_dim1], abs(d__1)); + } else if (t[k + 1 + k * t_dim1] == 0.) { + evk = (d__1 = t[k + k * t_dim1], abs(d__1)); + } else { + evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[ + k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k + + (k + 1) * t_dim1], abs(d__2))); + } + if (evi >= evk) { + i__ = k; + } else { + sorted = FALSE_; + ifst = i__; + ilst = k; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + if (info == 0) { + i__ = ilst; + } else { + i__ = k; + } + } + if (i__ == kend) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { + k = i__ + 1; + } else { + k = i__ + 2; + } + goto L40; + } + goto L30; +L50: + ; + } + // + // ==== Restore shift/eigenvalue array from T ==== + // + i__ = jw; +L60: + if (i__ >= infqr + 1) { + if (i__ == infqr + 1) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.; + --i__; + } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.; + --i__; + } else { + aa = t[i__ - 1 + (i__ - 1) * t_dim1]; + cc = t[i__ + (i__ - 1) * t_dim1]; + bb = t[i__ - 1 + i__ * t_dim1]; + dd = t[i__ + i__ * t_dim1]; + dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ + - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & + sn); + i__ += -2; + } + goto L60; + } + if (*ns < jw || s == 0.) { + if (*ns > 1 && s != 0.) { + // + // ==== Reflect spike back into lower triangle ==== + // + dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); + beta = work[1]; + dlarfg_(ns, &beta, &work[2], &c__1, &tau); + work[1] = 1.; + i__1 = jw - 2; + i__2 = jw - 2; + dlaset_("L", &i__1, &i__2, &c_b17, &c_b17, &t[t_dim1 + 3], ldt); + dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & + work[jw + 1]); + i__1 = *lwork - jw; + dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] + , &i__1, &info); + } + // + // ==== Copy updated reduced window into place ==== + // + if (kwtop > 1) { + h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; + } + dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] + , ldh); + i__1 = jw - 1; + i__2 = *ldt + 1; + i__3 = *ldh + 1; + dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], + &i__3); + // + // ==== Accumulate orthogonal matrix in order update + // . H and Z, if requested. ==== + // + if (*ns > 1 && s != 0.) { + i__1 = *lwork - jw; + dormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[jw + 1], &i__1, &info); + } + // + // ==== Update vertical slab in H ==== + // + if (*wantt) { + ltop = 1; + } else { + ltop = *ktop; + } + i__1 = kwtop - 1; + i__2 = *nv; + for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { + // Computing MIN + i__3 = *nv, i__4 = kwtop - krow; + kln = min(i__3,i__4); + dgemm_("N", "N", &kln, &jw, &jw, &c_b18, &h__[krow + kwtop * + h_dim1], ldh, &v[v_offset], ldv, &c_b17, &wv[wv_offset], + ldwv); + dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * + h_dim1], ldh); +// L70: + } + // + // ==== Update horizontal slab in H ==== + // + if (*wantt) { + i__2 = *n; + i__1 = *nh; + for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; + kcol += i__1) { + // Computing MIN + i__3 = *nh, i__4 = *n - kcol + 1; + kln = min(i__3,i__4); + dgemm_("C", "N", &jw, &kln, &jw, &c_b18, &v[v_offset], ldv, & + h__[kwtop + kcol * h_dim1], ldh, &c_b17, &t[t_offset], + ldt); + dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * + h_dim1], ldh); +// L80: + } + } + // + // ==== Update vertical slab in Z ==== + // + if (*wantz) { + i__1 = *ihiz; + i__2 = *nv; + for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { + // Computing MIN + i__3 = *nv, i__4 = *ihiz - krow + 1; + kln = min(i__3,i__4); + dgemm_("N", "N", &kln, &jw, &jw, &c_b18, &z__[krow + kwtop * + z_dim1], ldz, &v[v_offset], ldv, &c_b17, &wv[ + wv_offset], ldwv); + dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + + kwtop * z_dim1], ldz); +// L90: + } + } + } + // + // ==== Return the number of deflations ... ==== + // + *nd = jw - *ns; + // + // ==== ... and the number of shifts. (Subtracting + // . INFQR from the spike length takes care + // . of the case of a rare QR failure while + // . calculating eigenvalues of the deflation + // . window.) ==== + // + *ns -= infqr; + // + // ==== Return optimal workspace. ==== + // + work[1] = (double) lwkopt; + // + // ==== End of DLAQR3 ==== + // + return 0; +} // dlaqr3_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAQR4 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +// ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N +// LOGICAL WANTT, WANTZ +// .. +// .. Array Arguments .. +// DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), +// $ Z( LDZ, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLAQR4 implements one level of recursion for DLAQR0. +//> It is a complete implementation of the small bulge multi-shift +//> QR algorithm. It may be called by DLAQR0 and, for large enough +//> deflation window size, it may be called by DLAQR3. This +//> subroutine is identical to DLAQR0 except that it calls DLAQR2 +//> instead of DLAQR3. +//> +//> DLAQR4 computes the eigenvalues of a Hessenberg matrix H +//> and, optionally, the matrices T and Z from the Schur decomposition +//> H = Z T Z**T, where T is an upper quasi-triangular matrix (the +//> Schur form), and Z is the orthogonal matrix of Schur vectors. +//> +//> Optionally Z may be postmultiplied into an input orthogonal +//> matrix Q so that this routine can give the Schur factorization +//> of a matrix A which has been reduced to the Hessenberg form H +//> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] WANTT +//> \verbatim +//> WANTT is LOGICAL +//> = .TRUE. : the full Schur form T is required; +//> = .FALSE.: only eigenvalues are required. +//> \endverbatim +//> +//> \param[in] WANTZ +//> \verbatim +//> WANTZ is LOGICAL +//> = .TRUE. : the matrix of Schur vectors Z is required; +//> = .FALSE.: Schur vectors are not required. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix H. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> It is assumed that H is already upper triangular in rows +//> and columns 1:ILO-1 and IHI+1:N and, if ILO > 1, +//> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +//> previous call to DGEBAL, and then passed to DGEHRD when the +//> matrix output by DGEBAL is reduced to Hessenberg form. +//> Otherwise, ILO and IHI should be set to 1 and N, +//> respectively. If N > 0, then 1 <= ILO <= IHI <= N. +//> If N = 0, then ILO = 1 and IHI = 0. +//> \endverbatim +//> +//> \param[in,out] H +//> \verbatim +//> H is DOUBLE PRECISION array, dimension (LDH,N) +//> On entry, the upper Hessenberg matrix H. +//> On exit, if INFO = 0 and WANTT is .TRUE., then H contains +//> the upper quasi-triangular matrix T from the Schur +//> decomposition (the Schur form); 2-by-2 diagonal blocks +//> (corresponding to complex conjugate pairs of eigenvalues) +//> are returned in standard form, with H(i,i) = H(i+1,i+1) +//> and H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and WANTT is +//> .FALSE., then the contents of H are unspecified on exit. +//> (The output value of H when INFO > 0 is given under the +//> description of INFO below.) +//> +//> This subroutine may explicitly set H(i,j) = 0 for i > j and +//> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. +//> \endverbatim +//> +//> \param[in] LDH +//> \verbatim +//> LDH is INTEGER +//> The leading dimension of the array H. LDH >= max(1,N). +//> \endverbatim +//> +//> \param[out] WR +//> \verbatim +//> WR is DOUBLE PRECISION array, dimension (IHI) +//> \endverbatim +//> +//> \param[out] WI +//> \verbatim +//> WI is DOUBLE PRECISION array, dimension (IHI) +//> The real and imaginary parts, respectively, of the computed +//> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) +//> and WI(ILO:IHI). If two eigenvalues are computed as a +//> complex conjugate pair, they are stored in consecutive +//> elements of WR and WI, say the i-th and (i+1)th, with +//> WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., then +//> the eigenvalues are stored in the same order as on the +//> diagonal of the Schur form returned in H, with +//> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal +//> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +//> WI(i+1) = -WI(i). +//> \endverbatim +//> +//> \param[in] ILOZ +//> \verbatim +//> ILOZ is INTEGER +//> \endverbatim +//> +//> \param[in] IHIZ +//> \verbatim +//> IHIZ is INTEGER +//> Specify the rows of Z to which transformations must be +//> applied if WANTZ is .TRUE.. +//> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) +//> If WANTZ is .FALSE., then Z is not referenced. +//> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +//> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +//> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +//> (The output value of Z when INFO > 0 is given under +//> the description of INFO below.) +//> \endverbatim +//> +//> \param[in] LDZ +//> \verbatim +//> LDZ is INTEGER +//> The leading dimension of the array Z. if WANTZ is .TRUE. +//> then LDZ >= MAX(1,IHIZ). Otherwise, LDZ >= 1. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension LWORK +//> On exit, if LWORK = -1, WORK(1) returns an estimate of +//> the optimal value for LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the array WORK. LWORK >= max(1,N) +//> is sufficient, but LWORK typically as large as 6*N may +//> be required for optimal performance. A workspace query +//> to determine the optimal workspace size is recommended. +//> +//> If LWORK = -1, then DLAQR4 does a workspace query. +//> In this case, DLAQR4 checks the input parameters and +//> estimates the optimal workspace size for the given +//> values of N, ILO and IHI. The estimate is returned +//> in WORK(1). No error message related to LWORK is +//> issued by XERBLA. Neither H nor Z are accessed. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> > 0: if INFO = i, DLAQR4 failed to compute all of +//> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +//> and WI contain those eigenvalues which have been +//> successfully computed. (Failures are rare.) +//> +//> If INFO > 0 and WANT is .FALSE., then on exit, +//> the remaining unconverged eigenvalues are the eigen- +//> values of the upper Hessenberg matrix rows and +//> columns ILO through INFO of the final, output +//> value of H. +//> +//> If INFO > 0 and WANTT is .TRUE., then on exit +//> +//> (*) (initial value of H)*U = U*(final value of H) +//> +//> where U is a orthogonal matrix. The final +//> value of H is upper Hessenberg and triangular in +//> rows and columns INFO+1 through IHI. +//> +//> If INFO > 0 and WANTZ is .TRUE., then on exit +//> +//> (final value of Z(ILO:IHI,ILOZ:IHIZ) +//> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +//> +//> where U is the orthogonal matrix in (*) (regard- +//> less of the value of WANTT.) +//> +//> If INFO > 0 and WANTZ is .FALSE., then Z is not +//> accessed. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Karen Braman and Ralph Byers, Department of Mathematics, +//> University of Kansas, USA +// +//> \par References: +// ================ +//> +//> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +//> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +//> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +//> 929--947, 2002. +//> \n +//> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +//> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +//> of Matrix Analysis, volume 23, pages 948--973, 2002. +//> +// ===================================================================== +/* Subroutine */ int dlaqr4_(int *wantt, int *wantz, int *n, int *ilo, int * + ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int * + ihiz, double *z__, int *ldz, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__13 = 13; + int c__15 = 15; + int c_n1 = -1; + int c__12 = 12; + int c__14 = 14; + int c__16 = 16; + int c_false = FALSE_; + int c__1 = 1; + int c__3 = 3; + + // System generated locals + int h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2, d__3, d__4; + + // Local variables + int i__, k; + double aa, bb, cc, dd; + int ld; + double cs; + int nh, it, ks, kt; + double sn; + int ku, kv, ls, ns; + double ss; + int nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; + double swap; + int ktop; + double zdum[1] /* was [1][1] */; + int kacc22, itmax, nsmax, nwmax, kwtop; + extern /* Subroutine */ int dlaqr2_(int *, int *, int *, int *, int *, + int *, double *, int *, int *, int *, double *, int *, int *, int + *, double *, double *, double *, int *, int *, double *, int *, + int *, double *, int *, double *, int *), dlanv2_(double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *), dlaqr5_(int *, int *, int *, int *, + int *, int *, int *, double *, double *, double *, int *, int *, + int *, double *, int *, double *, int *, double *, int *, int *, + double *, int *, int *, double *, int *); + int nibble; + extern /* Subroutine */ int dlahqr_(int *, int *, int *, int *, int *, + double *, int *, double *, double *, int *, int *, double *, int * + , int *), dlacpy_(char *, int *, int *, double *, int *, double *, + int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + char jbcmpz[2+1]={'\0'}; + int nwupbd; + int sorted; + int lwkopt; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ================================================================ + // .. Parameters .. + // + // ==== Matrices of order NTINY or smaller must be processed by + // . DLAHQR because of insufficient subdiagonal scratch space. + // . (This is a hard limit.) ==== + // + // ==== Exceptional deflation windows: try to cure rare + // . slow convergence by varying the size of the + // . deflation window after KEXNW iterations. ==== + // + // ==== Exceptional shifts: try to cure rare slow convergence + // . with ad-hoc exceptional shifts every KEXSH iterations. + // . ==== + // + // ==== The constants WILK1 and WILK2 are used to form the + // . exceptional shifts. ==== + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Local Arrays .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // Parameter adjustments + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + // Function Body + *info = 0; + // + // ==== Quick return for N = 0: nothing to do. ==== + // + if (*n == 0) { + work[1] = 1.; + return 0; + } + if (*n <= 11) { + // + // ==== Tiny matrices must use DLAHQR. ==== + // + lwkopt = 1; + if (*lwork != -1) { + dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & + wi[1], iloz, ihiz, &z__[z_offset], ldz, info); + } + } else { + // + // ==== Use small bulge multi-shift QR with aggressive early + // . deflation on larger-than-tiny matrices. ==== + // + // ==== Hope for the best. ==== + // + *info = 0; + // + // ==== Set up job flags for ILAENV. ==== + // + if (*wantt) { + *(unsigned char *)jbcmpz = 'S'; + } else { + *(unsigned char *)jbcmpz = 'E'; + } + if (*wantz) { + *(unsigned char *)&jbcmpz[1] = 'V'; + } else { + *(unsigned char *)&jbcmpz[1] = 'N'; + } + // + // ==== NWR = recommended deflation window size. At this + // . point, N .GT. NTINY = 11, so there is enough + // . subdiagonal workspace for NWR.GE.2 as required. + // . (In fact, there is enough subdiagonal space for + // . NWR.GE.3.) ==== + // + nwr = ilaenv_(&c__13, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + nwr = max(2,nwr); + // Computing MIN + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2); + nwr = min(i__1,nwr); + // + // ==== NSR = recommended number of simultaneous shifts. + // . At this point N .GT. NTINY = 11, so there is at + // . enough subdiagonal workspace for NSR to be even + // . and greater than or equal to two as required. ==== + // + nsr = ilaenv_(&c__15, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + // Computing MIN + i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi - + *ilo; + nsr = min(i__1,i__2); + // Computing MAX + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = max(i__1,i__2); + // + // ==== Estimate optimal workspace ==== + // + // ==== Workspace query call to DLAQR2 ==== + // + i__1 = nwr + 1; + dlaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, + ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ + h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], + ldh, &work[1], &c_n1); + // + // ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== + // + // Computing MAX + i__1 = nsr * 3 / 2, i__2 = (int) work[1]; + lwkopt = max(i__1,i__2); + // + // ==== Quick return in case of workspace query. ==== + // + if (*lwork == -1) { + work[1] = (double) lwkopt; + return 0; + } + // + // ==== DLAHQR/DLAQR0 crossover point ==== + // + nmin = ilaenv_(&c__12, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + nmin = max(11,nmin); + // + // ==== Nibble crossover point ==== + // + nibble = ilaenv_(&c__14, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + nibble = max(0,nibble); + // + // ==== Accumulate reflections during ttswp? Use block + // . 2-by-2 structure during matrix-matrix multiply? ==== + // + kacc22 = ilaenv_(&c__16, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + kacc22 = max(0,kacc22); + kacc22 = min(2,kacc22); + // + // ==== NWMAX = the largest possible deflation window for + // . which there is sufficient workspace. ==== + // + // Computing MIN + i__1 = (*n - 1) / 3, i__2 = *lwork / 2; + nwmax = min(i__1,i__2); + nw = nwmax; + // + // ==== NSMAX = the Largest number of simultaneous shifts + // . for which there is sufficient workspace. ==== + // + // Computing MIN + i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3; + nsmax = min(i__1,i__2); + nsmax -= nsmax % 2; + // + // ==== NDFL: an iteration count restarted at deflation. ==== + // + ndfl = 1; + // + // ==== ITMAX = iteration limit ==== + // + // Computing MAX + i__1 = 10, i__2 = *ihi - *ilo + 1; + itmax = max(i__1,i__2) * 30; + // + // ==== Last row and column in the active block ==== + // + kbot = *ihi; + // + // ==== Main Loop ==== + // + i__1 = itmax; + for (it = 1; it <= i__1; ++it) { + // + // ==== Done when KBOT falls below ILO ==== + // + if (kbot < *ilo) { + goto L90; + } + // + // ==== Locate active block ==== + // + i__2 = *ilo + 1; + for (k = kbot; k >= i__2; --k) { + if (h__[k + (k - 1) * h_dim1] == 0.) { + goto L20; + } +// L10: + } + k = *ilo; +L20: + ktop = k; + // + // ==== Select deflation window size: + // . Typical Case: + // . If possible and advisable, nibble the entire + // . active block. If not, use size MIN(NWR,NWMAX) + // . or MIN(NWR+1,NWMAX) depending upon which has + // . the smaller corresponding subdiagonal entry + // . (a heuristic). + // . + // . Exceptional Case: + // . If there have been no deflations in KEXNW or + // . more iterations, then vary the deflation window + // . size. At first, because, larger windows are, + // . in general, more powerful than smaller ones, + // . rapidly increase the window to the maximum possible. + // . Then, gradually reduce the window size. ==== + // + nh = kbot - ktop + 1; + nwupbd = min(nh,nwmax); + if (ndfl < 5) { + nw = min(nwupbd,nwr); + } else { + // Computing MIN + i__2 = nwupbd, i__3 = nw << 1; + nw = min(i__2,i__3); + } + if (nw < nwmax) { + if (nw >= nh - 1) { + nw = nh; + } else { + kwtop = kbot - nw + 1; + if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) + > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], + abs(d__2))) { + ++nw; + } + } + } + if (ndfl < 5) { + ndec = -1; + } else if (ndec >= 0 || nw >= nwupbd) { + ++ndec; + if (nw - ndec < 2) { + ndec = 0; + } + nw -= ndec; + } + // + // ==== Aggressive early deflation: + // . split workspace under the subdiagonal into + // . - an nw-by-nw work array V in the lower + // . left-hand-corner, + // . - an NW-by-at-least-NW-but-more-is-better + // . (NW-by-NHO) horizontal work array along + // . the bottom edge, + // . - an at-least-NW-but-more-is-better (NHV-by-NW) + // . vertical work array along the left-hand-edge. + // . ==== + // + kv = *n - nw + 1; + kt = nw + 1; + nho = *n - nw - 1 - kt + 1; + kwv = nw + 2; + nve = *n - nw - kwv + 1; + // + // ==== Aggressive early deflation ==== + // + dlaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, + iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], + &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); + // + // ==== Adjust KBOT accounting for new deflations. ==== + // + kbot -= ld; + // + // ==== KS points to the shifts. ==== + // + ks = kbot - ls + 1; + // + // ==== Skip an expensive QR sweep if there is a (partly + // . heuristic) reason to expect that many eigenvalues + // . will deflate without it. Here, the QR sweep is + // . skipped if many eigenvalues have just been deflated + // . or if the remaining active block is small. + // + if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min( + nmin,nwmax)) { + // + // ==== NS = nominal number of simultaneous shifts. + // . This may be lowered (slightly) if DLAQR2 + // . did not provide that many shifts. ==== + // + // Computing MIN + // Computing MAX + i__4 = 2, i__5 = kbot - ktop; + i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5); + ns = min(i__2,i__3); + ns -= ns % 2; + // + // ==== If there have been no deflations + // . in a multiple of KEXSH iterations, + // . then try exceptional shifts. + // . Otherwise use shifts provided by + // . DLAQR2 above or from the eigenvalues + // . of a trailing principal submatrix. ==== + // + if (ndfl % 6 == 0) { + ks = kbot - ns + 1; + // Computing MAX + i__3 = ks + 1, i__4 = ktop + 2; + i__2 = max(i__3,i__4); + for (i__ = kbot; i__ >= i__2; i__ += -2) { + ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], + abs(d__2)); + aa = ss * .75 + h__[i__ + i__ * h_dim1]; + bb = ss; + cc = ss * -.4375; + dd = aa; + dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] + , &wr[i__], &wi[i__], &cs, &sn); +// L30: + } + if (ks == ktop) { + wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; + wi[ks + 1] = 0.; + wr[ks] = wr[ks + 1]; + wi[ks] = wi[ks + 1]; + } + } else { + // + // ==== Got NS/2 or fewer shifts? Use DLAHQR + // . on a trailing principal submatrix to + // . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, + // . there is enough space below the subdiagonal + // . to fit an NS-by-NS scratch array.) ==== + // + if (kbot - ks + 1 <= ns / 2) { + ks = kbot - ns + 1; + kt = *n - ns + 1; + dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & + h__[kt + h_dim1], ldh); + dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + + h_dim1], ldh, &wr[ks], &wi[ks], &c__1, & + c__1, zdum, &c__1, &inf); + ks += inf; + // + // ==== In case of a rare QR failure use + // . eigenvalues of the trailing 2-by-2 + // . principal submatrix. ==== + // + if (ks >= kbot) { + aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; + cc = h__[kbot + (kbot - 1) * h_dim1]; + bb = h__[kbot - 1 + kbot * h_dim1]; + dd = h__[kbot + kbot * h_dim1]; + dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ + kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) + ; + ks = kbot - 1; + } + } + if (kbot - ks + 1 > ns) { + // + // ==== Sort the shifts (Helps a little) + // . Bubble sort keeps complex conjugate + // . pairs together. ==== + // + sorted = FALSE_; + i__2 = ks + 1; + for (k = kbot; k >= i__2; --k) { + if (sorted) { + goto L60; + } + sorted = TRUE_; + i__3 = k - 1; + for (i__ = ks; i__ <= i__3; ++i__) { + if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[ + i__], abs(d__2)) < (d__3 = wr[i__ + 1] + , abs(d__3)) + (d__4 = wi[i__ + 1], + abs(d__4))) { + sorted = FALSE_; + swap = wr[i__]; + wr[i__] = wr[i__ + 1]; + wr[i__ + 1] = swap; + swap = wi[i__]; + wi[i__] = wi[i__ + 1]; + wi[i__ + 1] = swap; + } +// L40: + } +// L50: + } +L60: + ; + } + // + // ==== Shuffle shifts into pairs of real shifts + // . and pairs of complex conjugate shifts + // . assuming complex conjugate shifts are + // . already adjacent to one another. (Yes, + // . they are.) ==== + // + i__2 = ks + 2; + for (i__ = kbot; i__ >= i__2; i__ += -2) { + if (wi[i__] != -wi[i__ - 1]) { + swap = wr[i__]; + wr[i__] = wr[i__ - 1]; + wr[i__ - 1] = wr[i__ - 2]; + wr[i__ - 2] = swap; + swap = wi[i__]; + wi[i__] = wi[i__ - 1]; + wi[i__ - 1] = wi[i__ - 2]; + wi[i__ - 2] = swap; + } +// L70: + } + } + // + // ==== If there are only two shifts and both are + // . real, then use only one. ==== + // + if (kbot - ks + 1 == 2) { + if (wi[kbot] == 0.) { + if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs( + d__1)) < (d__2 = wr[kbot - 1] - h__[kbot + + kbot * h_dim1], abs(d__2))) { + wr[kbot - 1] = wr[kbot]; + } else { + wr[kbot] = wr[kbot - 1]; + } + } + } + // + // ==== Use up to NS of the the smallest magnitude + // . shifts. If there aren't NS shifts available, + // . then use them all, possibly dropping one to + // . make the number of shifts even. ==== + // + // Computing MIN + i__2 = ns, i__3 = kbot - ks + 1; + ns = min(i__2,i__3); + ns -= ns % 2; + ks = kbot - ns + 1; + // + // ==== Small-bulge multi-shift QR sweep: + // . split workspace under the subdiagonal into + // . - a KDU-by-KDU work array U in the lower + // . left-hand-corner, + // . - a KDU-by-at-least-KDU-but-more-is-better + // . (KDU-by-NHo) horizontal work array WH along + // . the bottom edge, + // . - and an at-least-KDU-but-more-is-better-by-KDU + // . (NVE-by-KDU) vertical work WV arrow along + // . the left-hand-edge. ==== + // + kdu = ns * 3 - 3; + ku = *n - kdu + 1; + kwh = kdu + 1; + nho = *n - kdu - 3 - (kdu + 1) + 1; + kwv = kdu + 4; + nve = *n - kdu - kwv + 1; + // + // ==== Small-bulge multi-shift QR sweep ==== + // + dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], + &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ + z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + + kwh * h_dim1], ldh); + } + // + // ==== Note progress (or the lack of it). ==== + // + if (ld > 0) { + ndfl = 1; + } else { + ++ndfl; + } + // + // ==== End of main loop ==== +// L80: + } + // + // ==== Iteration limit exceeded. Set INFO to show where + // . the problem occurred and exit. ==== + // + *info = kbot; +L90: + ; + } + // + // ==== Return the optimal value of LWORK. ==== + // + work[1] = (double) lwkopt; + // + // ==== End of DLAQR4 ==== + // + return 0; +} // dlaqr4_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAQR5 performs a single small-bulge multi-shift QR sweep. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAQR5 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, +// SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, +// LDU, NV, WV, LDWV, NH, WH, LDWH ) +// +// .. Scalar Arguments .. +// INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, +// $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV +// LOGICAL WANTT, WANTZ +// .. +// .. Array Arguments .. +// DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), +// $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), +// $ Z( LDZ, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLAQR5, called by DLAQR0, performs a +//> single small-bulge multi-shift QR sweep. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] WANTT +//> \verbatim +//> WANTT is LOGICAL +//> WANTT = .true. if the quasi-triangular Schur factor +//> is being computed. WANTT is set to .false. otherwise. +//> \endverbatim +//> +//> \param[in] WANTZ +//> \verbatim +//> WANTZ is LOGICAL +//> WANTZ = .true. if the orthogonal Schur factor is being +//> computed. WANTZ is set to .false. otherwise. +//> \endverbatim +//> +//> \param[in] KACC22 +//> \verbatim +//> KACC22 is INTEGER with value 0, 1, or 2. +//> Specifies the computation mode of far-from-diagonal +//> orthogonal updates. +//> = 0: DLAQR5 does not accumulate reflections and does not +//> use matrix-matrix multiply to update far-from-diagonal +//> matrix entries. +//> = 1: DLAQR5 accumulates reflections and uses matrix-matrix +//> multiply to update the far-from-diagonal matrix entries. +//> = 2: DLAQR5 accumulates reflections, uses matrix-matrix +//> multiply to update the far-from-diagonal matrix entries, +//> and takes advantage of 2-by-2 block structure during +//> matrix multiplies. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> N is the order of the Hessenberg matrix H upon which this +//> subroutine operates. +//> \endverbatim +//> +//> \param[in] KTOP +//> \verbatim +//> KTOP is INTEGER +//> \endverbatim +//> +//> \param[in] KBOT +//> \verbatim +//> KBOT is INTEGER +//> These are the first and last rows and columns of an +//> isolated diagonal block upon which the QR sweep is to be +//> applied. It is assumed without a check that +//> either KTOP = 1 or H(KTOP,KTOP-1) = 0 +//> and +//> either KBOT = N or H(KBOT+1,KBOT) = 0. +//> \endverbatim +//> +//> \param[in] NSHFTS +//> \verbatim +//> NSHFTS is INTEGER +//> NSHFTS gives the number of simultaneous shifts. NSHFTS +//> must be positive and even. +//> \endverbatim +//> +//> \param[in,out] SR +//> \verbatim +//> SR is DOUBLE PRECISION array, dimension (NSHFTS) +//> \endverbatim +//> +//> \param[in,out] SI +//> \verbatim +//> SI is DOUBLE PRECISION array, dimension (NSHFTS) +//> SR contains the real parts and SI contains the imaginary +//> parts of the NSHFTS shifts of origin that define the +//> multi-shift QR sweep. On output SR and SI may be +//> reordered. +//> \endverbatim +//> +//> \param[in,out] H +//> \verbatim +//> H is DOUBLE PRECISION array, dimension (LDH,N) +//> On input H contains a Hessenberg matrix. On output a +//> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied +//> to the isolated diagonal block in rows and columns KTOP +//> through KBOT. +//> \endverbatim +//> +//> \param[in] LDH +//> \verbatim +//> LDH is INTEGER +//> LDH is the leading dimension of H just as declared in the +//> calling procedure. LDH >= MAX(1,N). +//> \endverbatim +//> +//> \param[in] ILOZ +//> \verbatim +//> ILOZ is INTEGER +//> \endverbatim +//> +//> \param[in] IHIZ +//> \verbatim +//> IHIZ is INTEGER +//> Specify the rows of Z to which transformations must be +//> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (LDZ,IHIZ) +//> If WANTZ = .TRUE., then the QR Sweep orthogonal +//> similarity transformation is accumulated into +//> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +//> If WANTZ = .FALSE., then Z is unreferenced. +//> \endverbatim +//> +//> \param[in] LDZ +//> \verbatim +//> LDZ is INTEGER +//> LDA is the leading dimension of Z just as declared in +//> the calling procedure. LDZ >= N. +//> \endverbatim +//> +//> \param[out] V +//> \verbatim +//> V is DOUBLE PRECISION array, dimension (LDV,NSHFTS/2) +//> \endverbatim +//> +//> \param[in] LDV +//> \verbatim +//> LDV is INTEGER +//> LDV is the leading dimension of V as declared in the +//> calling procedure. LDV >= 3. +//> \endverbatim +//> +//> \param[out] U +//> \verbatim +//> U is DOUBLE PRECISION array, dimension (LDU,3*NSHFTS-3) +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER +//> LDU is the leading dimension of U just as declared in the +//> in the calling subroutine. LDU >= 3*NSHFTS-3. +//> \endverbatim +//> +//> \param[in] NV +//> \verbatim +//> NV is INTEGER +//> NV is the number of rows in WV agailable for workspace. +//> NV >= 1. +//> \endverbatim +//> +//> \param[out] WV +//> \verbatim +//> WV is DOUBLE PRECISION array, dimension (LDWV,3*NSHFTS-3) +//> \endverbatim +//> +//> \param[in] LDWV +//> \verbatim +//> LDWV is INTEGER +//> LDWV is the leading dimension of WV as declared in the +//> in the calling subroutine. LDWV >= NV. +//> \endverbatim +// +//> \param[in] NH +//> \verbatim +//> NH is INTEGER +//> NH is the number of columns in array WH available for +//> workspace. NH >= 1. +//> \endverbatim +//> +//> \param[out] WH +//> \verbatim +//> WH is DOUBLE PRECISION array, dimension (LDWH,NH) +//> \endverbatim +//> +//> \param[in] LDWH +//> \verbatim +//> LDWH is INTEGER +//> Leading dimension of WH just as declared in the +//> calling procedure. LDWH >= 3*NSHFTS-3. +//> \endverbatim +//> +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Karen Braman and Ralph Byers, Department of Mathematics, +//> University of Kansas, USA +// +//> \par References: +// ================ +//> +//> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +//> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +//> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +//> 929--947, 2002. +//> +// ===================================================================== +/* Subroutine */ int dlaqr5_(int *wantt, int *wantz, int *kacc22, int *n, int + *ktop, int *kbot, int *nshfts, double *sr, double *si, double *h__, + int *ldh, int *iloz, int *ihiz, double *z__, int *ldz, double *v, int + *ldv, double *u, int *ldu, int *nv, double *wv, int *ldwv, int *nh, + double *wh, int *ldwh) +{ + // Table of constant values + double c_b7 = 0.; + double c_b8 = 1.; + int c__3 = 3; + int c__1 = 1; + int c__2 = 2; + + // System generated locals + int h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1, + wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, + i__4, i__5, i__6, i__7; + double d__1, d__2, d__3, d__4, d__5; + + // Local variables + int i__, j, k, m, i2, j2, i4, j4, k1; + double h11, h12, h21, h22; + int m22, ns, nu; + double vt[3], scl; + int kdu, kms; + double ulp; + int knz, kzs; + double tst1, tst2, beta; + int blk22, bmp22; + int mend, jcol, jlen, jbot, mbot; + double swap; + int jtop, jrow, mtop; + double alpha; + int accum; + extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *, + double *, double *, int *, double *, int *, double *, double *, + int *); + int ndcol, incol, krcol, nbmps; + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, int *, + int *, double *, double *, int *, double *, int *), dlaqr1_(int *, + double *, int *, double *, double *, double *, double *, double * + ), dlabad_(double *, double *); + extern double dlamch_(char *); + extern /* Subroutine */ int dlarfg_(int *, double *, double *, int *, + double *), dlacpy_(char *, int *, int *, double *, int *, double * + , int *); + double safmin; + extern /* Subroutine */ int dlaset_(char *, int *, int *, double *, + double *, double *, int *); + double safmax, refsum; + int mstart; + double smlnum; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ================================================================ + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Intrinsic Functions .. + // + // .. + // .. Local Arrays .. + // .. + // .. External Subroutines .. + // .. + // .. Executable Statements .. + // + // ==== If there are no shifts, then there is nothing to do. ==== + // + // Parameter adjustments + --sr; + --si; + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1; + wv -= wv_offset; + wh_dim1 = *ldwh; + wh_offset = 1 + wh_dim1; + wh -= wh_offset; + + // Function Body + if (*nshfts < 2) { + return 0; + } + // + // ==== If the active block is empty or 1-by-1, then there + // . is nothing to do. ==== + // + if (*ktop >= *kbot) { + return 0; + } + // + // ==== Shuffle shifts into pairs of real shifts and pairs + // . of complex conjugate shifts assuming complex + // . conjugate shifts are already adjacent to one + // . another. ==== + // + i__1 = *nshfts - 2; + for (i__ = 1; i__ <= i__1; i__ += 2) { + if (si[i__] != -si[i__ + 1]) { + swap = sr[i__]; + sr[i__] = sr[i__ + 1]; + sr[i__ + 1] = sr[i__ + 2]; + sr[i__ + 2] = swap; + swap = si[i__]; + si[i__] = si[i__ + 1]; + si[i__ + 1] = si[i__ + 2]; + si[i__ + 2] = swap; + } +// L10: + } + // + // ==== NSHFTS is supposed to be even, but if it is odd, + // . then simply reduce it by one. The shuffle above + // . ensures that the dropped shift is real and that + // . the remaining shifts are paired. ==== + // + ns = *nshfts - *nshfts % 2; + // + // ==== Machine constants for deflation ==== + // + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((double) (*n) / ulp); + // + // ==== Use accumulated reflections to update far-from-diagonal + // . entries ? ==== + // + accum = *kacc22 == 1 || *kacc22 == 2; + // + // ==== If so, exploit the 2-by-2 block structure? ==== + // + blk22 = ns > 2 && *kacc22 == 2; + // + // ==== clear trash ==== + // + if (*ktop + 2 <= *kbot) { + h__[*ktop + 2 + *ktop * h_dim1] = 0.; + } + // + // ==== NBMPS = number of 2-shift bulges in the chain ==== + // + nbmps = ns / 2; + // + // ==== KDU = width of slab ==== + // + kdu = nbmps * 6 - 3; + // + // ==== Create and chase chains of NBMPS bulges ==== + // + i__1 = *kbot - 2; + i__2 = nbmps * 3 - 2; + for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 : + incol <= i__1; incol += i__2) { + ndcol = incol + kdu; + if (accum) { + dlaset_("ALL", &kdu, &kdu, &c_b7, &c_b8, &u[u_offset], ldu); + } + // + // ==== Near-the-diagonal bulge chase. The following loop + // . performs the near-the-diagonal part of a small bulge + // . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal + // . chunk extends from column INCOL to column NDCOL + // . (including both column INCOL and column NDCOL). The + // . following loop chases a 3*NBMPS column long chain of + // . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL + // . may be less than KTOP and and NDCOL may be greater than + // . KBOT indicating phantom columns from which to chase + // . bulges before they are actually introduced or to which + // . to chase bulges beyond column KBOT.) ==== + // + // Computing MIN + i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2; + i__3 = min(i__4,i__5); + for (krcol = incol; krcol <= i__3; ++krcol) { + // + // ==== Bulges number MTOP to MBOT are active double implicit + // . shift bulges. There may or may not also be small + // . 2-by-2 bulge, if there is room. The inactive bulges + // . (if any) must wait until the active bulges have moved + // . down the diagonal to make room. The phantom matrix + // . paradigm described above helps keep track. ==== + // + // Computing MAX + i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1; + mtop = max(i__4,i__5); + // Computing MIN + i__4 = nbmps, i__5 = (*kbot - krcol) / 3; + mbot = min(i__4,i__5); + m22 = mbot + 1; + bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2; + // + // ==== Generate reflections to chase the chain right + // . one column. (The minimum value of K is KTOP-1.) ==== + // + i__4 = mbot; + for (m = mtop; m <= i__4; ++m) { + k = krcol + (m - 1) * 3; + if (k == *ktop - 1) { + dlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &sr[(m + << 1) - 1], &si[(m << 1) - 1], &sr[m * 2], &si[m * + 2], &v[m * v_dim1 + 1]); + alpha = v[m * v_dim1 + 1]; + dlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m * + v_dim1 + 1]); + } else { + beta = h__[k + 1 + k * h_dim1]; + v[m * v_dim1 + 2] = h__[k + 2 + k * h_dim1]; + v[m * v_dim1 + 3] = h__[k + 3 + k * h_dim1]; + dlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m * + v_dim1 + 1]); + // + // ==== A Bulge may collapse because of vigilant + // . deflation or destructive underflow. In the + // . underflow case, try the two-small-subdiagonals + // . trick to try to reinflate the bulge. ==== + // + if (h__[k + 3 + k * h_dim1] != 0. || h__[k + 3 + (k + 1) * + h_dim1] != 0. || h__[k + 3 + (k + 2) * h_dim1] == + 0.) { + // + // ==== Typical case: not collapsed (yet). ==== + // + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.; + h__[k + 3 + k * h_dim1] = 0.; + } else { + // + // ==== Atypical case: collapsed. Attempt to + // . reintroduce ignoring H(K+1,K) and H(K+2,K). + // . If the fill resulting from the new + // . reflector is too large, then abandon it. + // . Otherwise, use the new one. ==== + // + dlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, & + sr[(m << 1) - 1], &si[(m << 1) - 1], &sr[m * + 2], &si[m * 2], vt); + alpha = vt[0]; + dlarfg_(&c__3, &alpha, &vt[1], &c__1, vt); + refsum = vt[0] * (h__[k + 1 + k * h_dim1] + vt[1] * + h__[k + 2 + k * h_dim1]); + if ((d__1 = h__[k + 2 + k * h_dim1] - refsum * vt[1], + abs(d__1)) + (d__2 = refsum * vt[2], abs(d__2) + ) > ulp * ((d__3 = h__[k + k * h_dim1], abs( + d__3)) + (d__4 = h__[k + 1 + (k + 1) * h_dim1] + , abs(d__4)) + (d__5 = h__[k + 2 + (k + 2) * + h_dim1], abs(d__5)))) { + // + // ==== Starting a new bulge here would + // . create non-negligible fill. Use + // . the old one with trepidation. ==== + // + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.; + h__[k + 3 + k * h_dim1] = 0.; + } else { + // + // ==== Stating a new bulge here would + // . create only negligible fill. + // . Replace the old reflector with + // . the new one. ==== + // + h__[k + 1 + k * h_dim1] -= refsum; + h__[k + 2 + k * h_dim1] = 0.; + h__[k + 3 + k * h_dim1] = 0.; + v[m * v_dim1 + 1] = vt[0]; + v[m * v_dim1 + 2] = vt[1]; + v[m * v_dim1 + 3] = vt[2]; + } + } + } +// L20: + } + // + // ==== Generate a 2-by-2 reflection, if needed. ==== + // + k = krcol + (m22 - 1) * 3; + if (bmp22) { + if (k == *ktop - 1) { + dlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[( + m22 << 1) - 1], &si[(m22 << 1) - 1], &sr[m22 * 2], + &si[m22 * 2], &v[m22 * v_dim1 + 1]); + beta = v[m22 * v_dim1 + 1]; + dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 + * v_dim1 + 1]); + } else { + beta = h__[k + 1 + k * h_dim1]; + v[m22 * v_dim1 + 2] = h__[k + 2 + k * h_dim1]; + dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 + * v_dim1 + 1]); + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.; + } + } + // + // ==== Multiply H by reflections from the left ==== + // + if (accum) { + jbot = min(ndcol,*kbot); + } else if (*wantt) { + jbot = *n; + } else { + jbot = *kbot; + } + i__4 = jbot; + for (j = max(*ktop,krcol); j <= i__4; ++j) { + // Computing MIN + i__5 = mbot, i__6 = (j - krcol + 2) / 3; + mend = min(i__5,i__6); + i__5 = mend; + for (m = mtop; m <= i__5; ++m) { + k = krcol + (m - 1) * 3; + refsum = v[m * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + v[ + m * v_dim1 + 2] * h__[k + 2 + j * h_dim1] + v[m * + v_dim1 + 3] * h__[k + 3 + j * h_dim1]); + h__[k + 1 + j * h_dim1] -= refsum; + h__[k + 2 + j * h_dim1] -= refsum * v[m * v_dim1 + 2]; + h__[k + 3 + j * h_dim1] -= refsum * v[m * v_dim1 + 3]; +// L30: + } +// L40: + } + if (bmp22) { + k = krcol + (m22 - 1) * 3; + // Computing MAX + i__4 = k + 1; + i__5 = jbot; + for (j = max(i__4,*ktop); j <= i__5; ++j) { + refsum = v[m22 * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + + v[m22 * v_dim1 + 2] * h__[k + 2 + j * h_dim1]); + h__[k + 1 + j * h_dim1] -= refsum; + h__[k + 2 + j * h_dim1] -= refsum * v[m22 * v_dim1 + 2]; +// L50: + } + } + // + // ==== Multiply H by reflections from the right. + // . Delay filling in the last row until the + // . vigilant deflation check is complete. ==== + // + if (accum) { + jtop = max(*ktop,incol); + } else if (*wantt) { + jtop = 1; + } else { + jtop = *ktop; + } + i__5 = mbot; + for (m = mtop; m <= i__5; ++m) { + if (v[m * v_dim1 + 1] != 0.) { + k = krcol + (m - 1) * 3; + // Computing MIN + i__6 = *kbot, i__7 = k + 3; + i__4 = min(i__6,i__7); + for (j = jtop; j <= i__4; ++j) { + refsum = v[m * v_dim1 + 1] * (h__[j + (k + 1) * + h_dim1] + v[m * v_dim1 + 2] * h__[j + (k + 2) + * h_dim1] + v[m * v_dim1 + 3] * h__[j + (k + + 3) * h_dim1]); + h__[j + (k + 1) * h_dim1] -= refsum; + h__[j + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 + + 2]; + h__[j + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + + 3]; +// L60: + } + if (accum) { + // + // ==== Accumulate U. (If necessary, update Z later + // . with with an efficient matrix-matrix + // . multiply.) ==== + // + kms = k - incol; + // Computing MAX + i__4 = 1, i__6 = *ktop - incol; + i__7 = kdu; + for (j = max(i__4,i__6); j <= i__7; ++j) { + refsum = v[m * v_dim1 + 1] * (u[j + (kms + 1) * + u_dim1] + v[m * v_dim1 + 2] * u[j + (kms + + 2) * u_dim1] + v[m * v_dim1 + 3] * u[j + + (kms + 3) * u_dim1]); + u[j + (kms + 1) * u_dim1] -= refsum; + u[j + (kms + 2) * u_dim1] -= refsum * v[m * + v_dim1 + 2]; + u[j + (kms + 3) * u_dim1] -= refsum * v[m * + v_dim1 + 3]; +// L70: + } + } else if (*wantz) { + // + // ==== U is not accumulated, so update Z + // . now by multiplying by reflections + // . from the right. ==== + // + i__7 = *ihiz; + for (j = *iloz; j <= i__7; ++j) { + refsum = v[m * v_dim1 + 1] * (z__[j + (k + 1) * + z_dim1] + v[m * v_dim1 + 2] * z__[j + (k + + 2) * z_dim1] + v[m * v_dim1 + 3] * z__[ + j + (k + 3) * z_dim1]); + z__[j + (k + 1) * z_dim1] -= refsum; + z__[j + (k + 2) * z_dim1] -= refsum * v[m * + v_dim1 + 2]; + z__[j + (k + 3) * z_dim1] -= refsum * v[m * + v_dim1 + 3]; +// L80: + } + } + } +// L90: + } + // + // ==== Special case: 2-by-2 reflection (if needed) ==== + // + k = krcol + (m22 - 1) * 3; + if (bmp22) { + if (v[m22 * v_dim1 + 1] != 0.) { + // Computing MIN + i__7 = *kbot, i__4 = k + 3; + i__5 = min(i__7,i__4); + for (j = jtop; j <= i__5; ++j) { + refsum = v[m22 * v_dim1 + 1] * (h__[j + (k + 1) * + h_dim1] + v[m22 * v_dim1 + 2] * h__[j + (k + + 2) * h_dim1]); + h__[j + (k + 1) * h_dim1] -= refsum; + h__[j + (k + 2) * h_dim1] -= refsum * v[m22 * v_dim1 + + 2]; +// L100: + } + if (accum) { + kms = k - incol; + // Computing MAX + i__5 = 1, i__7 = *ktop - incol; + i__4 = kdu; + for (j = max(i__5,i__7); j <= i__4; ++j) { + refsum = v[m22 * v_dim1 + 1] * (u[j + (kms + 1) * + u_dim1] + v[m22 * v_dim1 + 2] * u[j + ( + kms + 2) * u_dim1]); + u[j + (kms + 1) * u_dim1] -= refsum; + u[j + (kms + 2) * u_dim1] -= refsum * v[m22 * + v_dim1 + 2]; +// L110: + } + } else if (*wantz) { + i__4 = *ihiz; + for (j = *iloz; j <= i__4; ++j) { + refsum = v[m22 * v_dim1 + 1] * (z__[j + (k + 1) * + z_dim1] + v[m22 * v_dim1 + 2] * z__[j + ( + k + 2) * z_dim1]); + z__[j + (k + 1) * z_dim1] -= refsum; + z__[j + (k + 2) * z_dim1] -= refsum * v[m22 * + v_dim1 + 2]; +// L120: + } + } + } + } + // + // ==== Vigilant deflation check ==== + // + mstart = mtop; + if (krcol + (mstart - 1) * 3 < *ktop) { + ++mstart; + } + mend = mbot; + if (bmp22) { + ++mend; + } + if (krcol == *kbot - 2) { + ++mend; + } + i__4 = mend; + for (m = mstart; m <= i__4; ++m) { + // Computing MIN + i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3; + k = min(i__5,i__7); + // + // ==== The following convergence test requires that + // . the tradition small-compared-to-nearby-diagonals + // . criterion and the Ahues & Tisseur (LAWN 122, 1997) + // . criteria both be satisfied. The latter improves + // . accuracy in some examples. Falling back on an + // . alternate convergence criterion when TST1 or TST2 + // . is zero (as done here) is traditional but probably + // . unnecessary. ==== + // + if (h__[k + 1 + k * h_dim1] != 0.) { + tst1 = (d__1 = h__[k + k * h_dim1], abs(d__1)) + (d__2 = + h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); + if (tst1 == 0.) { + if (k >= *ktop + 1) { + tst1 += (d__1 = h__[k + (k - 1) * h_dim1], abs( + d__1)); + } + if (k >= *ktop + 2) { + tst1 += (d__1 = h__[k + (k - 2) * h_dim1], abs( + d__1)); + } + if (k >= *ktop + 3) { + tst1 += (d__1 = h__[k + (k - 3) * h_dim1], abs( + d__1)); + } + if (k <= *kbot - 2) { + tst1 += (d__1 = h__[k + 2 + (k + 1) * h_dim1], + abs(d__1)); + } + if (k <= *kbot - 3) { + tst1 += (d__1 = h__[k + 3 + (k + 1) * h_dim1], + abs(d__1)); + } + if (k <= *kbot - 4) { + tst1 += (d__1 = h__[k + 4 + (k + 1) * h_dim1], + abs(d__1)); + } + } + // Computing MAX + d__2 = smlnum, d__3 = ulp * tst1; + if ((d__1 = h__[k + 1 + k * h_dim1], abs(d__1)) <= max( + d__2,d__3)) { + // Computing MAX + d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)), + d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs( + d__2)); + h12 = max(d__3,d__4); + // Computing MIN + d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)), + d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs( + d__2)); + h21 = min(d__3,d__4); + // Computing MAX + d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs( + d__1)), d__4 = (d__2 = h__[k + k * h_dim1] - + h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); + h11 = max(d__3,d__4); + // Computing MIN + d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs( + d__1)), d__4 = (d__2 = h__[k + k * h_dim1] - + h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); + h22 = min(d__3,d__4); + scl = h11 + h12; + tst2 = h22 * (h11 / scl); + // + // Computing MAX + d__1 = smlnum, d__2 = ulp * tst2; + if (tst2 == 0. || h21 * (h12 / scl) <= max(d__1,d__2)) + { + h__[k + 1 + k * h_dim1] = 0.; + } + } + } +// L130: + } + // + // ==== Fill in the last row of each bulge. ==== + // + // Computing MIN + i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3; + mend = min(i__4,i__5); + i__4 = mend; + for (m = mtop; m <= i__4; ++m) { + k = krcol + (m - 1) * 3; + refsum = v[m * v_dim1 + 1] * v[m * v_dim1 + 3] * h__[k + 4 + ( + k + 3) * h_dim1]; + h__[k + 4 + (k + 1) * h_dim1] = -refsum; + h__[k + 4 + (k + 2) * h_dim1] = -refsum * v[m * v_dim1 + 2]; + h__[k + 4 + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3]; +// L140: + } + // + // ==== End of near-the-diagonal bulge chase. ==== + // +// L150: + } + // + // ==== Use U (if accumulated) to update far-from-diagonal + // . entries in H. If required, use U to update Z as + // . well. ==== + // + if (accum) { + if (*wantt) { + jtop = 1; + jbot = *n; + } else { + jtop = *ktop; + jbot = *kbot; + } + if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) { + // + // ==== Updates not exploiting the 2-by-2 block + // . structure of U. K1 and NU keep track of + // . the location and size of U in the special + // . cases of introducing bulges and chasing + // . bulges off the bottom. In these special + // . cases and in case the number of shifts + // . is NS = 2, there is no 2-by-2 block + // . structure to exploit. ==== + // + // Computing MAX + i__3 = 1, i__4 = *ktop - incol; + k1 = max(i__3,i__4); + // Computing MAX + i__3 = 0, i__4 = ndcol - *kbot; + nu = kdu - max(i__3,i__4) - k1 + 1; + // + // ==== Horizontal Multiply ==== + // + i__3 = jbot; + i__4 = *nh; + for (jcol = min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 : + jcol <= i__3; jcol += i__4) { + // Computing MIN + i__5 = *nh, i__7 = jbot - jcol + 1; + jlen = min(i__5,i__7); + dgemm_("C", "N", &nu, &jlen, &nu, &c_b8, &u[k1 + k1 * + u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1], + ldh, &c_b7, &wh[wh_offset], ldwh); + dlacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[ + incol + k1 + jcol * h_dim1], ldh); +// L160: + } + // + // ==== Vertical multiply ==== + // + i__4 = max(*ktop,incol) - 1; + i__3 = *nv; + for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4; + jrow += i__3) { + // Computing MIN + i__5 = *nv, i__7 = max(*ktop,incol) - jrow; + jlen = min(i__5,i__7); + dgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &h__[jrow + ( + incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1], + ldu, &c_b7, &wv[wv_offset], ldwv); + dlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[ + jrow + (incol + k1) * h_dim1], ldh); +// L170: + } + // + // ==== Z multiply (also vertical) ==== + // + if (*wantz) { + i__3 = *ihiz; + i__4 = *nv; + for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3; + jrow += i__4) { + // Computing MIN + i__5 = *nv, i__7 = *ihiz - jrow + 1; + jlen = min(i__5,i__7); + dgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &z__[jrow + ( + incol + k1) * z_dim1], ldz, &u[k1 + k1 * + u_dim1], ldu, &c_b7, &wv[wv_offset], ldwv); + dlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[ + jrow + (incol + k1) * z_dim1], ldz); +// L180: + } + } + } else { + // + // ==== Updates exploiting U's 2-by-2 block structure. + // . (I2, I4, J2, J4 are the last rows and columns + // . of the blocks.) ==== + // + i2 = (kdu + 1) / 2; + i4 = kdu; + j2 = i4 - i2; + j4 = kdu; + // + // ==== KZS and KNZ deal with the band of zeros + // . along the diagonal of one of the triangular + // . blocks. ==== + // + kzs = j4 - j2 - (ns + 1); + knz = ns + 1; + // + // ==== Horizontal multiply ==== + // + i__4 = jbot; + i__3 = *nh; + for (jcol = min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 : + jcol <= i__4; jcol += i__3) { + // Computing MIN + i__5 = *nh, i__7 = jbot - jcol + 1; + jlen = min(i__5,i__7); + // + // ==== Copy bottom of H to top+KZS of scratch ==== + // (The first KZS rows get multiplied by zero.) ==== + // + dlacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol * + h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh); + // + // ==== Multiply by U21**T ==== + // + dlaset_("ALL", &kzs, &jlen, &c_b7, &c_b7, &wh[wh_offset], + ldwh); + dtrmm_("L", "U", "C", "N", &knz, &jlen, &c_b8, &u[j2 + 1 + + (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1] + , ldwh); + // + // ==== Multiply top of H by U11**T ==== + // + dgemm_("C", "N", &i2, &jlen, &j2, &c_b8, &u[u_offset], + ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b8, + &wh[wh_offset], ldwh); + // + // ==== Copy top of H to bottom of WH ==== + // + dlacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1] + , ldh, &wh[i2 + 1 + wh_dim1], ldwh); + // + // ==== Multiply by U21**T ==== + // + dtrmm_("L", "L", "C", "N", &j2, &jlen, &c_b8, &u[(i2 + 1) + * u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh); + // + // ==== Multiply by U22 ==== + // + i__5 = i4 - i2; + i__7 = j4 - j2; + dgemm_("C", "N", &i__5, &jlen, &i__7, &c_b8, &u[j2 + 1 + ( + i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 + + jcol * h_dim1], ldh, &c_b8, &wh[i2 + 1 + wh_dim1], + ldwh); + // + // ==== Copy it back ==== + // + dlacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[ + incol + 1 + jcol * h_dim1], ldh); +// L190: + } + // + // ==== Vertical multiply ==== + // + i__3 = max(incol,*ktop) - 1; + i__4 = *nv; + for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3; + jrow += i__4) { + // Computing MIN + i__5 = *nv, i__7 = max(incol,*ktop) - jrow; + jlen = min(i__5,i__7); + // + // ==== Copy right of H to scratch (the first KZS + // . columns get multiplied by zero) ==== + // + dlacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) * + h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv) + ; + // + // ==== Multiply by U21 ==== + // + dlaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[wv_offset], + ldwv); + dtrmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 + 1 + + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) * + wv_dim1 + 1], ldwv); + // + // ==== Multiply by U11 ==== + // + dgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &h__[jrow + ( + incol + 1) * h_dim1], ldh, &u[u_offset], ldu, & + c_b8, &wv[wv_offset], ldwv); + // + // ==== Copy left of H to right of scratch ==== + // + dlacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) * + h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv); + // + // ==== Multiply by U21 ==== + // + i__5 = i4 - i2; + dtrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(i2 + + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1] + , ldwv); + // + // ==== Multiply by U22 ==== + // + i__5 = i4 - i2; + i__7 = j4 - j2; + dgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &h__[jrow + ( + incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 + + 1) * u_dim1], ldu, &c_b8, &wv[(i2 + 1) * wv_dim1 + + 1], ldwv); + // + // ==== Copy it back ==== + // + dlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[ + jrow + (incol + 1) * h_dim1], ldh); +// L200: + } + // + // ==== Multiply Z (also vertical) ==== + // + if (*wantz) { + i__4 = *ihiz; + i__3 = *nv; + for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4; + jrow += i__3) { + // Computing MIN + i__5 = *nv, i__7 = *ihiz - jrow + 1; + jlen = min(i__5,i__7); + // + // ==== Copy right of Z to left of scratch (first + // . KZS columns get multiplied by zero) ==== + // + dlacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 + + j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 + + 1], ldwv); + // + // ==== Multiply by U12 ==== + // + dlaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[ + wv_offset], ldwv); + dtrmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 + + 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) + * wv_dim1 + 1], ldwv); + // + // ==== Multiply by U11 ==== + // + dgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &z__[jrow + ( + incol + 1) * z_dim1], ldz, &u[u_offset], ldu, + &c_b8, &wv[wv_offset], ldwv); + // + // ==== Copy left of Z to right of scratch ==== + // + dlacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) * + z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1], + ldwv); + // + // ==== Multiply by U21 ==== + // + i__5 = i4 - i2; + dtrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[( + i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * + wv_dim1 + 1], ldwv); + // + // ==== Multiply by U22 ==== + // + i__5 = i4 - i2; + i__7 = j4 - j2; + dgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &z__[ + jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2 + + 1 + (i2 + 1) * u_dim1], ldu, &c_b8, &wv[(i2 + + 1) * wv_dim1 + 1], ldwv); + // + // ==== Copy the result back to Z ==== + // + dlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, & + z__[jrow + (incol + 1) * z_dim1], ldz); +// L210: + } + } + } + } +// L220: + } + // + // ==== End of DLAQR5 ==== + // + return 0; +} // dlaqr5_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLARFX + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) +// +// .. Scalar Arguments .. +// CHARACTER SIDE +// INTEGER LDC, M, N +// DOUBLE PRECISION TAU +// .. +// .. Array Arguments .. +// DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLARFX 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**T +//> +//> where tau is a real scalar and v is a real vector. +//> +//> If tau = 0, then H is taken to be the unit matrix +//> +//> This version uses inline code if H has order < 11. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'L': form H * C +//> = 'R': form C * H +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. +//> \endverbatim +//> +//> \param[in] V +//> \verbatim +//> V is DOUBLE PRECISION array, dimension (M) if SIDE = 'L' +//> or (N) if SIDE = 'R' +//> The vector v in the representation of H. +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION +//> The value tau in the representation of H. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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'. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= (1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension +//> (N) if SIDE = 'L' +//> or (M) if SIDE = 'R' +//> WORK is not referenced if H has order < 11. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlarfx_(char *side, int *m, int *n, double *v, double * + tau, double *c__, int *ldc, double *work) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int c_dim1, c_offset, i__1; + + // Local variables + int j; + double t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7, v8, + v9, t10, v10, sum; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *); + extern int lsame_(char *, char *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Executable Statements .. + // + // Parameter adjustments + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + // Function Body + if (*tau == 0.) { + return 0; + } + if (lsame_(side, "L")) { + // + // Form H * C, where H has order m. + // + switch (*m) { + case 1: goto L10; + case 2: goto L30; + case 3: goto L50; + case 4: goto L70; + case 5: goto L90; + case 6: goto L110; + case 7: goto L130; + case 8: goto L150; + case 9: goto L170; + case 10: goto L190; + } + // + // Code for general M + // + dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); + goto L410; +L10: + // + // Special code for 1 x 1 Householder + // + t1 = 1. - *tau * v[1] * v[1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1]; +// L20: + } + goto L410; +L30: + // + // Special code for 2 x 2 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; +// L40: + } + goto L410; +L50: + // + // Special code for 3 x 3 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; +// L60: + } + goto L410; +L70: + // + // Special code for 4 x 4 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; +// L80: + } + goto L410; +L90: + // + // Special code for 5 x 5 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; +// L100: + } + goto L410; +L110: + // + // Special code for 6 x 6 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; +// L120: + } + goto L410; +L130: + // + // Special code for 7 x 7 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; +// L140: + } + goto L410; +L150: + // + // Special code for 8 x 8 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; +// L160: + } + goto L410; +L170: + // + // Special code for 9 x 9 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + v9 = v[9]; + t9 = *tau * v9; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * + c_dim1 + 9]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; + c__[j * c_dim1 + 9] -= sum * t9; +// L180: + } + goto L410; +L190: + // + // Special code for 10 x 10 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + v9 = v[9]; + t9 = *tau * v9; + v10 = v[10]; + t10 = *tau * v10; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * + c_dim1 + 9] + v10 * c__[j * c_dim1 + 10]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; + c__[j * c_dim1 + 9] -= sum * t9; + c__[j * c_dim1 + 10] -= sum * t10; +// L200: + } + goto L410; + } else { + // + // Form C * H, where H has order n. + // + switch (*n) { + case 1: goto L210; + case 2: goto L230; + case 3: goto L250; + case 4: goto L270; + case 5: goto L290; + case 6: goto L310; + case 7: goto L330; + case 8: goto L350; + case 9: goto L370; + case 10: goto L390; + } + // + // Code for general N + // + dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); + goto L410; +L210: + // + // Special code for 1 x 1 Householder + // + t1 = 1. - *tau * v[1] * v[1]; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + c__[j + c_dim1] = t1 * c__[j + c_dim1]; +// L220: + } + goto L410; +L230: + // + // Special code for 2 x 2 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; +// L240: + } + goto L410; +L250: + // + // Special code for 3 x 3 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; +// L260: + } + goto L410; +L270: + // + // Special code for 4 x 4 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; +// L280: + } + goto L410; +L290: + // + // Special code for 5 x 5 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; +// L300: + } + goto L410; +L310: + // + // Special code for 6 x 6 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; +// L320: + } + goto L410; +L330: + // + // Special code for 7 x 7 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; +// L340: + } + goto L410; +L350: + // + // Special code for 8 x 8 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; +// L360: + } + goto L410; +L370: + // + // Special code for 9 x 9 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + v9 = v[9]; + t9 = *tau * v9; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[ + j + c_dim1 * 9]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; + c__[j + c_dim1 * 9] -= sum * t9; +// L380: + } + goto L410; +L390: + // + // Special code for 10 x 10 Householder + // + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + v9 = v[9]; + t9 = *tau * v9; + v10 = v[10]; + t10 = *tau * v10; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[ + j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; + c__[j + c_dim1 * 9] -= sum * t9; + c__[j + c_dim1 * 10] -= sum * t10; +// L400: + } + goto L410; + } +L410: + return 0; + // + // End of DLARFX + // +} // dlarfx_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASY2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, +// LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +// +// .. Scalar Arguments .. +// LOGICAL LTRANL, LTRANR +// INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 +// DOUBLE PRECISION SCALE, XNORM +// .. +// .. Array Arguments .. +// DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), +// $ X( LDX, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in +//> +//> op(TL)*X + ISGN*X*op(TR) = SCALE*B, +//> +//> where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or +//> -1. op(T) = T or T**T, where T**T denotes the transpose of T. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] LTRANL +//> \verbatim +//> LTRANL is LOGICAL +//> On entry, LTRANL specifies the op(TL): +//> = .FALSE., op(TL) = TL, +//> = .TRUE., op(TL) = TL**T. +//> \endverbatim +//> +//> \param[in] LTRANR +//> \verbatim +//> LTRANR is LOGICAL +//> On entry, LTRANR specifies the op(TR): +//> = .FALSE., op(TR) = TR, +//> = .TRUE., op(TR) = TR**T. +//> \endverbatim +//> +//> \param[in] ISGN +//> \verbatim +//> ISGN is INTEGER +//> On entry, ISGN specifies the sign of the equation +//> as described before. ISGN may only be 1 or -1. +//> \endverbatim +//> +//> \param[in] N1 +//> \verbatim +//> N1 is INTEGER +//> On entry, N1 specifies the order of matrix TL. +//> N1 may only be 0, 1 or 2. +//> \endverbatim +//> +//> \param[in] N2 +//> \verbatim +//> N2 is INTEGER +//> On entry, N2 specifies the order of matrix TR. +//> N2 may only be 0, 1 or 2. +//> \endverbatim +//> +//> \param[in] TL +//> \verbatim +//> TL is DOUBLE PRECISION array, dimension (LDTL,2) +//> On entry, TL contains an N1 by N1 matrix. +//> \endverbatim +//> +//> \param[in] LDTL +//> \verbatim +//> LDTL is INTEGER +//> The leading dimension of the matrix TL. LDTL >= max(1,N1). +//> \endverbatim +//> +//> \param[in] TR +//> \verbatim +//> TR is DOUBLE PRECISION array, dimension (LDTR,2) +//> On entry, TR contains an N2 by N2 matrix. +//> \endverbatim +//> +//> \param[in] LDTR +//> \verbatim +//> LDTR is INTEGER +//> The leading dimension of the matrix TR. LDTR >= max(1,N2). +//> \endverbatim +//> +//> \param[in] B +//> \verbatim +//> B is DOUBLE PRECISION array, dimension (LDB,2) +//> On entry, the N1 by N2 matrix B contains the right-hand +//> side of the equation. +//> \endverbatim +//> +//> \param[in] LDB +//> \verbatim +//> LDB is INTEGER +//> The leading dimension of the matrix B. LDB >= max(1,N1). +//> \endverbatim +//> +//> \param[out] SCALE +//> \verbatim +//> SCALE is DOUBLE PRECISION +//> On exit, SCALE contains the scale factor. SCALE is chosen +//> less than or equal to 1 to prevent the solution overflowing. +//> \endverbatim +//> +//> \param[out] X +//> \verbatim +//> X is DOUBLE PRECISION array, dimension (LDX,2) +//> On exit, X contains the N1 by N2 solution. +//> \endverbatim +//> +//> \param[in] LDX +//> \verbatim +//> LDX is INTEGER +//> The leading dimension of the matrix X. LDX >= max(1,N1). +//> \endverbatim +//> +//> \param[out] XNORM +//> \verbatim +//> XNORM is DOUBLE PRECISION +//> On exit, XNORM is the infinity-norm of the solution. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> On exit, INFO is set to +//> 0: successful exit. +//> 1: TL and TR have too close eigenvalues, so TL or +//> TR is perturbed to get a nonsingular equation. +//> NOTE: In the interests of speed, this routine does not +//> check the inputs for errors. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup doubleSYauxiliary +// +// ===================================================================== +/* Subroutine */ int dlasy2_(int *ltranl, int *ltranr, int *isgn, int *n1, + int *n2, double *tl, int *ldtl, double *tr, int *ldtr, double *b, int + *ldb, double *scale, double *x, int *ldx, double *xnorm, int *info) +{ + // Table of constant values + int c__4 = 4; + int c__1 = 1; + int c__16 = 16; + int c__0 = 0; + + /* Initialized data */ + + static int locu12[4] = { 3,4,1,2 }; + static int locl21[4] = { 2,1,4,3 }; + static int locu22[4] = { 4,3,2,1 }; + static int xswpiv[4] = { FALSE_,FALSE_,TRUE_,TRUE_ }; + static int bswpiv[4] = { FALSE_,TRUE_,FALSE_,TRUE_ }; + + // System generated locals + int b_dim1, b_offset, tl_dim1, tl_offset, tr_dim1, tr_offset, x_dim1, + x_offset; + double d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8; + + // Local variables + int i__, j, k; + double x2[2], l21, u11, u12; + int ip, jp; + double u22, t16[16] /* was [4][4] */, gam, bet, eps, sgn, tmp[4], tau1, + btmp[4], smin; + int ipiv; + double temp; + int jpiv[4]; + double xmax; + int ipsv, jpsv; + int bswap; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ), dswap_(int *, double *, int *, double *, int *); + int xswap; + extern double dlamch_(char *); + extern int idamax_(int *, double *, int *); + double smlnum; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + //===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. Local Arrays .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Data statements .. + // Parameter adjustments + tl_dim1 = *ldtl; + tl_offset = 1 + tl_dim1; + tl -= tl_offset; + tr_dim1 = *ldtr; + tr_offset = 1 + tr_dim1; + tr -= tr_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + + // Function Body + // .. + // .. Executable Statements .. + // + // Do not check the input parameters for errors + // + *info = 0; + // + // Quick return if possible + // + if (*n1 == 0 || *n2 == 0) { + return 0; + } + // + // Set constants to control overflow + // + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + sgn = (double) (*isgn); + k = *n1 + *n1 + *n2 - 2; + switch (k) { + case 1: goto L10; + case 2: goto L20; + case 3: goto L30; + case 4: goto L50; + } + // + // 1 by 1: TL11*X + SGN*X*TR11 = B11 + // +L10: + tau1 = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + bet = abs(tau1); + if (bet <= smlnum) { + tau1 = smlnum; + bet = smlnum; + *info = 1; + } + *scale = 1.; + gam = (d__1 = b[b_dim1 + 1], abs(d__1)); + if (smlnum * gam > bet) { + *scale = 1. / gam; + } + x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / tau1; + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)); + return 0; + // + // 1 by 2: + // TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] + // [TR21 TR22] + // +L20: + // + // Computing MAX + // Computing MAX + d__7 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__8 = (d__2 = tr[tr_dim1 + 1] + , abs(d__2)), d__7 = max(d__7,d__8), d__8 = (d__3 = tr[(tr_dim1 << + 1) + 1], abs(d__3)), d__7 = max(d__7,d__8), d__8 = (d__4 = tr[ + tr_dim1 + 2], abs(d__4)), d__7 = max(d__7,d__8), d__8 = (d__5 = + tr[(tr_dim1 << 1) + 2], abs(d__5)); + d__6 = eps * max(d__7,d__8); + smin = max(d__6,smlnum); + tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + tmp[3] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2]; + if (*ltranr) { + tmp[1] = sgn * tr[tr_dim1 + 2]; + tmp[2] = sgn * tr[(tr_dim1 << 1) + 1]; + } else { + tmp[1] = sgn * tr[(tr_dim1 << 1) + 1]; + tmp[2] = sgn * tr[tr_dim1 + 2]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[(b_dim1 << 1) + 1]; + goto L40; + // + // 2 by 1: + // op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] + // [TL21 TL22] [X21] [X21] [B21] + // +L30: + // Computing MAX + // Computing MAX + d__7 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__8 = (d__2 = tl[tl_dim1 + 1] + , abs(d__2)), d__7 = max(d__7,d__8), d__8 = (d__3 = tl[(tl_dim1 << + 1) + 1], abs(d__3)), d__7 = max(d__7,d__8), d__8 = (d__4 = tl[ + tl_dim1 + 2], abs(d__4)), d__7 = max(d__7,d__8), d__8 = (d__5 = + tl[(tl_dim1 << 1) + 2], abs(d__5)); + d__6 = eps * max(d__7,d__8); + smin = max(d__6,smlnum); + tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + tmp[3] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1]; + if (*ltranl) { + tmp[1] = tl[(tl_dim1 << 1) + 1]; + tmp[2] = tl[tl_dim1 + 2]; + } else { + tmp[1] = tl[tl_dim1 + 2]; + tmp[2] = tl[(tl_dim1 << 1) + 1]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[b_dim1 + 2]; +L40: + // + // Solve 2 by 2 system using complete pivoting. + // Set pivots less than SMIN to SMIN. + // + ipiv = idamax_(&c__4, tmp, &c__1); + u11 = tmp[ipiv - 1]; + if (abs(u11) <= smin) { + *info = 1; + u11 = smin; + } + u12 = tmp[locu12[ipiv - 1] - 1]; + l21 = tmp[locl21[ipiv - 1] - 1] / u11; + u22 = tmp[locu22[ipiv - 1] - 1] - u12 * l21; + xswap = xswpiv[ipiv - 1]; + bswap = bswpiv[ipiv - 1]; + if (abs(u22) <= smin) { + *info = 1; + u22 = smin; + } + if (bswap) { + temp = btmp[1]; + btmp[1] = btmp[0] - l21 * temp; + btmp[0] = temp; + } else { + btmp[1] -= l21 * btmp[0]; + } + *scale = 1.; + if (smlnum * 2. * abs(btmp[1]) > abs(u22) || smlnum * 2. * abs(btmp[0]) > + abs(u11)) { + // Computing MAX + d__1 = abs(btmp[0]), d__2 = abs(btmp[1]); + *scale = .5 / max(d__1,d__2); + btmp[0] *= *scale; + btmp[1] *= *scale; + } + x2[1] = btmp[1] / u22; + x2[0] = btmp[0] / u11 - u12 / u11 * x2[1]; + if (xswap) { + temp = x2[1]; + x2[1] = x2[0]; + x2[0] = temp; + } + x[x_dim1 + 1] = x2[0]; + if (*n1 == 1) { + x[(x_dim1 << 1) + 1] = x2[1]; + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << 1) + + 1], abs(d__2)); + } else { + x[x_dim1 + 2] = x2[1]; + // Computing MAX + d__3 = (d__1 = x[x_dim1 + 1], abs(d__1)), d__4 = (d__2 = x[x_dim1 + 2] + , abs(d__2)); + *xnorm = max(d__3,d__4); + } + return 0; + // + // 2 by 2: + // op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] + // [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] + // + // Solve equivalent 4 by 4 system using complete pivoting. + // Set pivots less than SMIN to SMIN. + // +L50: + // Computing MAX + d__5 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__6 = (d__2 = tr[(tr_dim1 << + 1) + 1], abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 = tr[ + tr_dim1 + 2], abs(d__3)), d__5 = max(d__5,d__6), d__6 = (d__4 = + tr[(tr_dim1 << 1) + 2], abs(d__4)); + smin = max(d__5,d__6); + // Computing MAX + d__5 = smin, d__6 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__5 = max(d__5, + d__6), d__6 = (d__2 = tl[(tl_dim1 << 1) + 1], abs(d__2)), d__5 = + max(d__5,d__6), d__6 = (d__3 = tl[tl_dim1 + 2], abs(d__3)), d__5 = + max(d__5,d__6), d__6 = (d__4 = tl[(tl_dim1 << 1) + 2], abs(d__4)) + ; + smin = max(d__5,d__6); + // Computing MAX + d__1 = eps * smin; + smin = max(d__1,smlnum); + btmp[0] = 0.; + dcopy_(&c__16, btmp, &c__0, t16, &c__1); + t16[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + t16[5] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1]; + t16[10] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2]; + t16[15] = tl[(tl_dim1 << 1) + 2] + sgn * tr[(tr_dim1 << 1) + 2]; + if (*ltranl) { + t16[4] = tl[tl_dim1 + 2]; + t16[1] = tl[(tl_dim1 << 1) + 1]; + t16[14] = tl[tl_dim1 + 2]; + t16[11] = tl[(tl_dim1 << 1) + 1]; + } else { + t16[4] = tl[(tl_dim1 << 1) + 1]; + t16[1] = tl[tl_dim1 + 2]; + t16[14] = tl[(tl_dim1 << 1) + 1]; + t16[11] = tl[tl_dim1 + 2]; + } + if (*ltranr) { + t16[8] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[13] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[2] = sgn * tr[tr_dim1 + 2]; + t16[7] = sgn * tr[tr_dim1 + 2]; + } else { + t16[8] = sgn * tr[tr_dim1 + 2]; + t16[13] = sgn * tr[tr_dim1 + 2]; + t16[2] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[7] = sgn * tr[(tr_dim1 << 1) + 1]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[b_dim1 + 2]; + btmp[2] = b[(b_dim1 << 1) + 1]; + btmp[3] = b[(b_dim1 << 1) + 2]; + // + // Perform elimination + // + for (i__ = 1; i__ <= 3; ++i__) { + xmax = 0.; + for (ip = i__; ip <= 4; ++ip) { + for (jp = i__; jp <= 4; ++jp) { + if ((d__1 = t16[ip + (jp << 2) - 5], abs(d__1)) >= xmax) { + xmax = (d__1 = t16[ip + (jp << 2) - 5], abs(d__1)); + ipsv = ip; + jpsv = jp; + } +// L60: + } +// L70: + } + if (ipsv != i__) { + dswap_(&c__4, &t16[ipsv - 1], &c__4, &t16[i__ - 1], &c__4); + temp = btmp[i__ - 1]; + btmp[i__ - 1] = btmp[ipsv - 1]; + btmp[ipsv - 1] = temp; + } + if (jpsv != i__) { + dswap_(&c__4, &t16[(jpsv << 2) - 4], &c__1, &t16[(i__ << 2) - 4], + &c__1); + } + jpiv[i__ - 1] = jpsv; + if ((d__1 = t16[i__ + (i__ << 2) - 5], abs(d__1)) < smin) { + *info = 1; + t16[i__ + (i__ << 2) - 5] = smin; + } + for (j = i__ + 1; j <= 4; ++j) { + t16[j + (i__ << 2) - 5] /= t16[i__ + (i__ << 2) - 5]; + btmp[j - 1] -= t16[j + (i__ << 2) - 5] * btmp[i__ - 1]; + for (k = i__ + 1; k <= 4; ++k) { + t16[j + (k << 2) - 5] -= t16[j + (i__ << 2) - 5] * t16[i__ + ( + k << 2) - 5]; +// L80: + } +// L90: + } +// L100: + } + if (abs(t16[15]) < smin) { + *info = 1; + t16[15] = smin; + } + *scale = 1.; + if (smlnum * 8. * abs(btmp[0]) > abs(t16[0]) || smlnum * 8. * abs(btmp[1]) + > abs(t16[5]) || smlnum * 8. * abs(btmp[2]) > abs(t16[10]) || + smlnum * 8. * abs(btmp[3]) > abs(t16[15])) { + // Computing MAX + d__1 = abs(btmp[0]), d__2 = abs(btmp[1]), d__1 = max(d__1,d__2), d__2 + = abs(btmp[2]), d__1 = max(d__1,d__2), d__2 = abs(btmp[3]); + *scale = .125 / max(d__1,d__2); + btmp[0] *= *scale; + btmp[1] *= *scale; + btmp[2] *= *scale; + btmp[3] *= *scale; + } + for (i__ = 1; i__ <= 4; ++i__) { + k = 5 - i__; + temp = 1. / t16[k + (k << 2) - 5]; + tmp[k - 1] = btmp[k - 1] * temp; + for (j = k + 1; j <= 4; ++j) { + tmp[k - 1] -= temp * t16[k + (j << 2) - 5] * tmp[j - 1]; +// L110: + } +// L120: + } + for (i__ = 1; i__ <= 3; ++i__) { + if (jpiv[4 - i__ - 1] != 4 - i__) { + temp = tmp[4 - i__ - 1]; + tmp[4 - i__ - 1] = tmp[jpiv[4 - i__ - 1] - 1]; + tmp[jpiv[4 - i__ - 1] - 1] = temp; + } +// L130: + } + x[x_dim1 + 1] = tmp[0]; + x[x_dim1 + 2] = tmp[1]; + x[(x_dim1 << 1) + 1] = tmp[2]; + x[(x_dim1 << 1) + 2] = tmp[3]; + // Computing MAX + d__1 = abs(tmp[0]) + abs(tmp[2]), d__2 = abs(tmp[1]) + abs(tmp[3]); + *xnorm = max(d__1,d__2); + return 0; + // + // End of DLASY2 + // +} // dlasy2_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORGHR +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORGHR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER IHI, ILO, INFO, LDA, LWORK, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DORGHR generates a real orthogonal matrix Q which is defined as the +//> product of IHI-ILO elementary reflectors of order N, as returned by +//> DGEHRD: +//> +//> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix Q. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> +//> ILO and IHI must have the same values as in the previous call +//> of DGEHRD. Q is equal to the unit matrix except in the +//> submatrix Q(ilo+1:ihi,ilo+1:ihi). +//> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> On entry, the vectors which define the elementary reflectors, +//> as returned by DGEHRD. +//> On exit, the N-by-N orthogonal matrix Q. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,N). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (N-1) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGEHRD. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the array WORK. LWORK >= IHI-ILO. +//> For optimum performance LWORK >= (IHI-ILO)*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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dorghr_(int *n, int *ilo, int *ihi, double *a, int *lda, + double *tau, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + + // System generated locals + int a_dim1, a_offset, i__1, i__2; + + // Local variables + int i__, j, nb, nh, iinfo; + extern /* Subroutine */ int xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + extern /* Subroutine */ int dorgqr_(int *, int *, int *, double *, int *, + double *, double *, int *, int *); + int lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + --tau; + --work; + + // Function Body + *info = 0; + nh = *ihi - *ilo; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > max(1,*n)) { + *info = -2; + } else if (*ihi < min(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < max(1,*n)) { + *info = -5; + } else if (*lwork < max(1,nh) && ! lquery) { + *info = -8; + } + if (*info == 0) { + nb = ilaenv_(&c__1, "DORGQR", " ", &nh, &nh, &nh, &c_n1); + lwkopt = max(1,nh) * nb; + work[1] = (double) lwkopt; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGHR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + // + // Quick return if possible + // + if (*n == 0) { + work[1] = 1.; + return 0; + } + // + // Shift the vectors which define the elementary reflectors one + // column to the right, and set the first ilo and the last n-ihi + // rows and columns to those of the unit matrix + // + i__1 = *ilo + 1; + for (j = *ihi; j >= i__1; --j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +// L10: + } + i__2 = *ihi; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; +// L20: + } + i__2 = *n; + for (i__ = *ihi + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +// L30: + } +// L40: + } + i__1 = *ilo; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +// L50: + } + a[j + j * a_dim1] = 1.; +// L60: + } + i__1 = *n; + for (j = *ihi + 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +// L70: + } + a[j + j * a_dim1] = 1.; +// L80: + } + if (nh > 0) { + // + // Generate Q(ilo+1:ihi,ilo+1:ihi) + // + dorgqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[* + ilo], &work[1], lwork, &iinfo); + } + work[1] = (double) lwkopt; + return 0; + // + // End of DORGHR + // +} // dorghr_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORMHR +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORMHR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, +// LDC, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER SIDE, TRANS +// INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DORMHR 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 +//> IHI-ILO elementary reflectors, as returned by DGEHRD: +//> +//> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'L': apply Q or Q**T from the Left; +//> = 'R': apply Q or Q**T from the Right. +//> \endverbatim +//> +//> \param[in] TRANS +//> \verbatim +//> TRANS is CHARACTER*1 +//> = 'N': No transpose, apply Q; +//> = 'T': Transpose, apply Q**T. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. N >= 0. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> +//> ILO and IHI must have the same values as in the previous call +//> of DGEHRD. Q is equal to the unit matrix except in the +//> submatrix Q(ilo+1:ihi,ilo+1:ihi). +//> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and +//> ILO = 1 and IHI = 0, if M = 0; +//> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and +//> ILO = 1 and IHI = 0, if N = 0. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension +//> (LDA,M) if SIDE = 'L' +//> (LDA,N) if SIDE = 'R' +//> The vectors which define the elementary reflectors, as +//> returned by DGEHRD. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. +//> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is 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 DGEHRD. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= max(1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dormhr_(char *side, char *trans, int *m, int *n, int * + ilo, int *ihi, double *a, int *lda, double *tau, double *c__, int * + ldc, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__2 = 2; + + // System generated locals + address a__1[2]; + int a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2; + char ch__1[2+1]={'\0'}; + + // Local variables + int i1, i2, nb, mi, nh, ni, nq, nw; + int left; + extern int lsame_(char *, char *); + int iinfo; + extern /* Subroutine */ int xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + extern /* Subroutine */ int dormqr_(char *, char *, int *, int *, int *, + double *, int *, double *, double *, int *, double *, int *, int * + ); + int lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + nh = *ihi - *ilo; + left = lsame_(side, "L"); + 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 (! lsame_(trans, "N") && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ilo < 1 || *ilo > max(1,nq)) { + *info = -5; + } else if (*ihi < min(*ilo,nq) || *ihi > nq) { + *info = -6; + } else if (*lda < max(1,nq)) { + *info = -8; + } else if (*ldc < max(1,*m)) { + *info = -11; + } else if (*lwork < max(1,nw) && ! lquery) { + *info = -13; + } + if (*info == 0) { + 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); + nb = ilaenv_(&c__1, "DORMQR", ch__1, &nh, n, &nh, &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); + nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &nh, &nh, &c_n1); + } + lwkopt = max(1,nw) * nb; + work[1] = (double) lwkopt; + } + if (*info != 0) { + i__2 = -(*info); + xerbla_("DORMHR", &i__2); + return 0; + } else if (lquery) { + return 0; + } + // + // Quick return if possible + // + if (*m == 0 || *n == 0 || nh == 0) { + work[1] = 1.; + return 0; + } + if (left) { + mi = nh; + ni = *n; + i1 = *ilo + 1; + i2 = 1; + } else { + mi = *m; + ni = nh; + i1 = 1; + i2 = *ilo + 1; + } + dormqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, & + tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); + work[1] = (double) lwkopt; + return 0; + // + // End of DORMHR + // +} // dormhr_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DTREVC3 +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DTREVC3 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, +// VR, LDVR, MM, M, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER HOWMNY, SIDE +// INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +// .. +// .. Array Arguments .. +// LOGICAL SELECT( * ) +// DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +// $ WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DTREVC3 computes some or all of the right and/or left eigenvectors of +//> a real upper quasi-triangular matrix T. +//> Matrices of this type are produced by the Schur factorization of +//> a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. +//> +//> The right eigenvector x and the left eigenvector y of T corresponding +//> to an eigenvalue w are defined by: +//> +//> T*x = w*x, (y**T)*T = w*(y**T) +//> +//> where y**T denotes the transpose of the vector y. +//> The eigenvalues are not input to this routine, but are read directly +//> from the diagonal blocks of T. +//> +//> This routine returns the matrices X and/or Y of right and left +//> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +//> input matrix. If Q is the orthogonal factor that reduces a matrix +//> A to Schur form T, then Q*X and Q*Y are the matrices of right and +//> left eigenvectors of A. +//> +//> This uses a Level 3 BLAS version of the back transformation. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'R': compute right eigenvectors only; +//> = 'L': compute left eigenvectors only; +//> = 'B': compute both right and left eigenvectors. +//> \endverbatim +//> +//> \param[in] HOWMNY +//> \verbatim +//> HOWMNY is CHARACTER*1 +//> = 'A': compute all right and/or left eigenvectors; +//> = 'B': compute all right and/or left eigenvectors, +//> backtransformed by the matrices in VR and/or VL; +//> = 'S': compute selected right and/or left eigenvectors, +//> as indicated by the logical array SELECT. +//> \endverbatim +//> +//> \param[in,out] SELECT +//> \verbatim +//> SELECT is LOGICAL array, dimension (N) +//> If HOWMNY = 'S', SELECT specifies the eigenvectors to be +//> computed. +//> If w(j) is a real eigenvalue, the corresponding real +//> eigenvector is computed if SELECT(j) is .TRUE.. +//> If w(j) and w(j+1) are the real and imaginary parts of a +//> complex eigenvalue, the corresponding complex eigenvector is +//> computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +//> on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +//> .FALSE.. +//> Not referenced if HOWMNY = 'A' or 'B'. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix T. N >= 0. +//> \endverbatim +//> +//> \param[in] T +//> \verbatim +//> T is DOUBLE PRECISION array, dimension (LDT,N) +//> The upper quasi-triangular matrix T in Schur canonical form. +//> \endverbatim +//> +//> \param[in] LDT +//> \verbatim +//> LDT is INTEGER +//> The leading dimension of the array T. LDT >= max(1,N). +//> \endverbatim +//> +//> \param[in,out] VL +//> \verbatim +//> VL is DOUBLE PRECISION array, dimension (LDVL,MM) +//> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +//> contain an N-by-N matrix Q (usually the orthogonal matrix Q +//> of Schur vectors returned by DHSEQR). +//> On exit, if SIDE = 'L' or 'B', VL contains: +//> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +//> if HOWMNY = 'B', the matrix Q*Y; +//> if HOWMNY = 'S', the left eigenvectors of T specified by +//> SELECT, stored consecutively in the columns +//> of VL, in the same order as their +//> eigenvalues. +//> A complex eigenvector corresponding to a complex eigenvalue +//> is stored in two consecutive columns, the first holding the +//> real part, and the second the imaginary part. +//> Not referenced if SIDE = 'R'. +//> \endverbatim +//> +//> \param[in] LDVL +//> \verbatim +//> LDVL is INTEGER +//> The leading dimension of the array VL. +//> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. +//> \endverbatim +//> +//> \param[in,out] VR +//> \verbatim +//> VR is DOUBLE PRECISION array, dimension (LDVR,MM) +//> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +//> contain an N-by-N matrix Q (usually the orthogonal matrix Q +//> of Schur vectors returned by DHSEQR). +//> On exit, if SIDE = 'R' or 'B', VR contains: +//> if HOWMNY = 'A', the matrix X of right eigenvectors of T; +//> if HOWMNY = 'B', the matrix Q*X; +//> if HOWMNY = 'S', the right eigenvectors of T specified by +//> SELECT, stored consecutively in the columns +//> of VR, in the same order as their +//> eigenvalues. +//> A complex eigenvector corresponding to a complex eigenvalue +//> is stored in two consecutive columns, the first holding the +//> real part and the second the imaginary part. +//> Not referenced if SIDE = 'L'. +//> \endverbatim +//> +//> \param[in] LDVR +//> \verbatim +//> LDVR is INTEGER +//> The leading dimension of the array VR. +//> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. +//> \endverbatim +//> +//> \param[in] MM +//> \verbatim +//> MM is INTEGER +//> The number of columns in the arrays VL and/or VR. MM >= M. +//> \endverbatim +//> +//> \param[out] M +//> \verbatim +//> M is INTEGER +//> The number of columns in the arrays VL and/or VR actually +//> used to store the eigenvectors. +//> If HOWMNY = 'A' or 'B', M is set to N. +//> Each selected real eigenvector occupies one column and each +//> selected complex eigenvector occupies two columns. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of array WORK. LWORK >= max(1,3*N). +//> For optimum performance, LWORK >= N + 2*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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +// @precisions fortran d -> s +// +//> \ingroup doubleOTHERcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> The algorithm used in this program is basically backward (forward) +//> substitution, with scaling to make the the code robust against +//> possible overflow. +//> +//> Each eigenvector is normalized so that the element of largest +//> magnitude has magnitude 1; here the magnitude of a complex number +//> (x,y) is taken to be |x| + |y|. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dtrevc3_(char *side, char *howmny, int *select, int *n, + double *t, int *ldt, double *vl, int *ldvl, double *vr, int *ldvr, + int *mm, int *m, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__2 = 2; + double c_b17 = 0.; + int c_false = FALSE_; + double c_b29 = 1.; + int c_true = TRUE_; + + // System generated locals + address a__1[2]; + int t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1[2], + i__2, i__3, i__4; + double d__1, d__2, d__3, d__4; + char ch__1[2+1]={'\0'}; + + // Local variables + int i__, j, k; + double x[4] /* was [2][2] */; + int j1, j2, iscomplex[128], nb, ii, ki, ip, is, iv; + double wi, wr; + int ki2; + double rec, ulp, beta, emax; + int pair; + extern double ddot_(int *, double *, int *, double *, int *); + int allv; + int ierr; + double unfl, ovfl, smin; + int over; + double vmax; + int jnxt; + extern /* Subroutine */ int dscal_(int *, double *, double *, int *); + double scale; + extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *, + double *, double *, int *, double *, int *, double *, double *, + int *); + extern int lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, int *, int *, double *, double + *, int *, double *, int *, double *, double *, int *); + double remax; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + int leftv, bothv; + extern /* Subroutine */ int daxpy_(int *, double *, double *, int *, + double *, int *); + double vcrit; + int somev; + double xnorm; + extern /* Subroutine */ int dlaln2_(int *, int *, int *, double *, double + *, double *, int *, double *, double *, double *, int *, double *, + double *, double *, int *, double *, double *, int *), dlabad_( + double *, double *); + extern double dlamch_(char *); + extern int idamax_(int *, double *, int *); + extern /* Subroutine */ int dlaset_(char *, int *, int *, double *, + double *, double *, int *), xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + extern /* Subroutine */ int dlacpy_(char *, int *, int *, double *, int *, + double *, int *); + double bignum; + int rightv; + int maxwrk; + double smlnum; + int lquery; + + // + // -- LAPACK computational routine (version 3.8.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Local Arrays .. + // .. + // .. Executable Statements .. + // + // Decode and test the input parameters + // + // Parameter adjustments + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --work; + + // Function Body + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + allv = lsame_(howmny, "A"); + over = lsame_(howmny, "B"); + somev = lsame_(howmny, "S"); + *info = 0; + // Writing concatenation + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = howmny; + s_cat(ch__1, a__1, i__1, &c__2); + nb = ilaenv_(&c__1, "DTREVC", ch__1, n, &c_n1, &c_n1, &c_n1); + maxwrk = *n + (*n << 1) * nb; + work[1] = (double) maxwrk; + lquery = *lwork == -1; + if (! rightv && ! leftv) { + *info = -1; + } else if (! allv && ! over && ! somev) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < max(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -10; + } else /* if(complicated condition) */ { + // Computing MAX + i__2 = 1, i__3 = *n * 3; + if (*lwork < max(i__2,i__3) && ! lquery) { + *info = -14; + } else { + // + // Set M to the number of columns required to store the selected + // eigenvectors, standardize the array SELECT if necessary, and + // test MM. + // + if (somev) { + *m = 0; + pair = FALSE_; + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (pair) { + pair = FALSE_; + select[j] = FALSE_; + } else { + if (j < *n) { + if (t[j + 1 + j * t_dim1] == 0.) { + if (select[j]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[j] || select[j + 1]) { + select[j] = TRUE_; + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +// L10: + } + } else { + *m = *n; + } + if (*mm < *m) { + *info = -11; + } + } + } + if (*info != 0) { + i__2 = -(*info); + xerbla_("DTREVC3", &i__2); + return 0; + } else if (lquery) { + return 0; + } + // + // Quick return if possible. + // + if (*n == 0) { + return 0; + } + // + // Use blocked version of back-transformation if sufficient workspace. + // Zero-out the workspace to avoid potential NaN propagation. + // + if (over && *lwork >= *n + (*n << 4)) { + nb = (*lwork - *n) / (*n << 1); + nb = min(nb,128); + i__2 = (nb << 1) + 1; + dlaset_("F", n, &i__2, &c_b17, &c_b17, &work[1], n); + } else { + nb = 1; + } + // + // Set the constants to control overflow. + // + unfl = dlamch_("Safe minimum"); + ovfl = 1. / unfl; + dlabad_(&unfl, &ovfl); + ulp = dlamch_("Precision"); + smlnum = unfl * (*n / ulp); + bignum = (1. - ulp) / smlnum; + // + // Compute 1-norm of each column of strictly upper triangular + // part of T to control overflow in triangular solver. + // + work[1] = 0.; + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + work[j] = 0.; + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1)); +// L20: + } +// L30: + } + // + // Index IP is used to specify the real or complex eigenvalue: + // IP = 0, real eigenvalue, + // 1, first of conjugate complex pair: (wr,wi) + // -1, second of conjugate complex pair: (wr,wi) + // ISCOMPLEX array stores IP for each column in current block. + // + if (rightv) { + // + // ============================================================ + // Compute right eigenvectors. + // + // IV is index of column in current block. + // For complex right vector, uses IV-1 for real part and IV for complex part. + // Non-blocked version always uses IV=2; + // blocked version starts with IV=NB, goes down to 1 or 2. + // (Note the "0-th" column is used for 1-norms computed above.) + iv = 2; + if (nb > 2) { + iv = nb; + } + ip = 0; + is = *m; + for (ki = *n; ki >= 1; --ki) { + if (ip == -1) { + // previous iteration (ki+1) was second of conjugate pair, + // so this ki is first of conjugate pair; skip to end of loop + ip = 1; + goto L140; + } else if (ki == 1) { + // last column, so this ki must be real eigenvalue + ip = 0; + } else if (t[ki + (ki - 1) * t_dim1] == 0.) { + // zero on sub-diagonal, so this ki is real eigenvalue + ip = 0; + } else { + // non-zero on sub-diagonal, so this ki is second of conjugate pair + ip = -1; + } + if (somev) { + if (ip == 0) { + if (! select[ki]) { + goto L140; + } + } else { + if (! select[ki - 1]) { + goto L140; + } + } + } + // + // Compute the KI-th eigenvalue (WR,WI). + // + wr = t[ki + ki * t_dim1]; + wi = 0.; + if (ip != 0) { + wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) * + sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2))); + } + // Computing MAX + d__1 = ulp * (abs(wr) + abs(wi)); + smin = max(d__1,smlnum); + if (ip == 0) { + // + // -------------------------------------------------------- + // Real right eigenvector + // + work[ki + iv * *n] = 1.; + // + // Form right-hand side. + // + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + work[k + iv * *n] = -t[k + ki * t_dim1]; +// L50: + } + // + // Solve upper quasi-triangular system: + // [ T(1:KI-1,1:KI-1) - WR ]*X = SCALE*WORK. + // + jnxt = ki - 1; + for (j = ki - 1; j >= 1; --j) { + if (j > jnxt) { + goto L60; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnxt = j - 2; + } + } + if (j1 == j2) { + // + // 1-by-1 diagonal block + // + dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + // + // Scale X(1,1) to avoid overflow when updating + // the right-hand side. + // + if (xnorm > 1.) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + scale /= xnorm; + } + } + // + // Scale if necessary + // + if (scale != 1.) { + dscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j + iv * *n] = x[0]; + // + // Update right-hand side + // + i__2 = j - 1; + d__1 = -x[0]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + } else { + // + // 2-by-2 diagonal block + // + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b29, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b29, &c_b29, & + work[j - 1 + iv * *n], n, &wr, &c_b17, x, & + c__2, &scale, &xnorm, &ierr); + // + // Scale X(1,1) and X(2,1) to avoid overflow when + // updating the right-hand side. + // + if (xnorm > 1.) { + // Computing MAX + d__1 = work[j - 1], d__2 = work[j]; + beta = max(d__1,d__2); + if (beta > bignum / xnorm) { + x[0] /= xnorm; + x[1] /= xnorm; + scale /= xnorm; + } + } + // + // Scale if necessary + // + if (scale != 1.) { + dscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j - 1 + iv * *n] = x[0]; + work[j + iv * *n] = x[1]; + // + // Update right-hand side + // + i__2 = j - 2; + d__1 = -x[0]; + daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[iv * *n + 1], &c__1); + i__2 = j - 2; + d__1 = -x[1]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + } +L60: + ; + } + // + // Copy the vector x or Q*x to VR and normalize. + // + if (! over) { + // ------------------------------ + // no back-transform: copy x to VR and normalize. + dcopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + + 1], &c__1); + ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); + remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1)); + dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + vr[k + is * vr_dim1] = 0.; +// L70: + } + } else if (nb == 1) { + // ------------------------------ + // version 1: back-transform each vector with GEMV, Q*x. + if (ki > 1) { + i__2 = ki - 1; + dgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[iv * *n + 1], &c__1, &work[ki + iv * *n], + &vr[ki * vr_dim1 + 1], &c__1); + } + ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1); + remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1)); + dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } else { + // ------------------------------ + // version 2: back-transform block of vectors with GEMM + // zero out below vector + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + iv * *n] = 0.; + } + iscomplex[iv - 1] = ip; + // back-transform and normalization is done below + } + } else { + // + // -------------------------------------------------------- + // Complex right eigenvector. + // + // Initial solve + // [ ( T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I*WI) ]*X = 0. + // [ ( T(KI, KI-1) T(KI, KI) ) ] + // + if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >= (d__2 = t[ + ki + (ki - 1) * t_dim1], abs(d__2))) { + work[ki - 1 + (iv - 1) * *n] = 1.; + work[ki + iv * *n] = wi / t[ki - 1 + ki * t_dim1]; + } else { + work[ki - 1 + (iv - 1) * *n] = -wi / t[ki + (ki - 1) * + t_dim1]; + work[ki + iv * *n] = 1.; + } + work[ki + (iv - 1) * *n] = 0.; + work[ki - 1 + iv * *n] = 0.; + // + // Form right-hand side. + // + i__2 = ki - 2; + for (k = 1; k <= i__2; ++k) { + work[k + (iv - 1) * *n] = -work[ki - 1 + (iv - 1) * *n] * + t[k + (ki - 1) * t_dim1]; + work[k + iv * *n] = -work[ki + iv * *n] * t[k + ki * + t_dim1]; +// L80: + } + // + // Solve upper quasi-triangular system: + // [ T(1:KI-2,1:KI-2) - (WR+i*WI) ]*X = SCALE*(WORK+i*WORK2) + // + jnxt = ki - 2; + for (j = ki - 2; j >= 1; --j) { + if (j > jnxt) { + goto L90; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnxt = j - 2; + } + } + if (j1 == j2) { + // + // 1-by-1 diagonal block + // + dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + ( + iv - 1) * *n], n, &wr, &wi, x, &c__2, &scale, + &xnorm, &ierr); + // + // Scale X(1,1) and X(1,2) to avoid overflow when + // updating the right-hand side. + // + if (xnorm > 1.) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + x[2] /= xnorm; + scale /= xnorm; + } + } + // + // Scale if necessary + // + if (scale != 1.) { + dscal_(&ki, &scale, &work[(iv - 1) * *n + 1], & + c__1); + dscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j + (iv - 1) * *n] = x[0]; + work[j + iv * *n] = x[2]; + // + // Update the right-hand side + // + i__2 = j - 1; + d__1 = -x[0]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + (iv - 1) * *n + 1], &c__1); + i__2 = j - 1; + d__1 = -x[2]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + } else { + // + // 2-by-2 diagonal block + // + dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b29, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b29, &c_b29, & + work[j - 1 + (iv - 1) * *n], n, &wr, &wi, x, & + c__2, &scale, &xnorm, &ierr); + // + // Scale X to avoid overflow when updating + // the right-hand side. + // + if (xnorm > 1.) { + // Computing MAX + d__1 = work[j - 1], d__2 = work[j]; + beta = max(d__1,d__2); + if (beta > bignum / xnorm) { + rec = 1. / xnorm; + x[0] *= rec; + x[2] *= rec; + x[1] *= rec; + x[3] *= rec; + scale *= rec; + } + } + // + // Scale if necessary + // + if (scale != 1.) { + dscal_(&ki, &scale, &work[(iv - 1) * *n + 1], & + c__1); + dscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j - 1 + (iv - 1) * *n] = x[0]; + work[j + (iv - 1) * *n] = x[1]; + work[j - 1 + iv * *n] = x[2]; + work[j + iv * *n] = x[3]; + // + // Update the right-hand side + // + i__2 = j - 2; + d__1 = -x[0]; + daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[(iv - 1) * *n + 1], &c__1); + i__2 = j - 2; + d__1 = -x[1]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + (iv - 1) * *n + 1], &c__1); + i__2 = j - 2; + d__1 = -x[2]; + daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[iv * *n + 1], &c__1); + i__2 = j - 2; + d__1 = -x[3]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + } +L90: + ; + } + // + // Copy the vector x or Q*x to VR and normalize. + // + if (! over) { + // ------------------------------ + // no back-transform: copy x to VR and normalize. + dcopy_(&ki, &work[(iv - 1) * *n + 1], &c__1, &vr[(is - 1) + * vr_dim1 + 1], &c__1); + dcopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + + 1], &c__1); + emax = 0.; + i__2 = ki; + for (k = 1; k <= i__2; ++k) { + // Computing MAX + d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1] + , abs(d__1)) + (d__2 = vr[k + is * vr_dim1], + abs(d__2)); + emax = max(d__3,d__4); +// L100: + } + remax = 1. / emax; + dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1); + dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + vr[k + (is - 1) * vr_dim1] = 0.; + vr[k + is * vr_dim1] = 0.; +// L110: + } + } else if (nb == 1) { + // ------------------------------ + // version 1: back-transform each vector with GEMV, Q*x. + if (ki > 2) { + i__2 = ki - 2; + dgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[(iv - 1) * *n + 1], &c__1, &work[ki - 1 + + (iv - 1) * *n], &vr[(ki - 1) * vr_dim1 + 1], + &c__1); + i__2 = ki - 2; + dgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[iv * *n + 1], &c__1, &work[ki + iv * *n], + &vr[ki * vr_dim1 + 1], &c__1); + } else { + dscal_(n, &work[ki - 1 + (iv - 1) * *n], &vr[(ki - 1) + * vr_dim1 + 1], &c__1); + dscal_(n, &work[ki + iv * *n], &vr[ki * vr_dim1 + 1], + &c__1); + } + emax = 0.; + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + // Computing MAX + d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1] + , abs(d__1)) + (d__2 = vr[k + ki * vr_dim1], + abs(d__2)); + emax = max(d__3,d__4); +// L120: + } + remax = 1. / emax; + dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1); + dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } else { + // ------------------------------ + // version 2: back-transform block of vectors with GEMM + // zero out below vector + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + (iv - 1) * *n] = 0.; + work[k + iv * *n] = 0.; + } + iscomplex[iv - 2] = -ip; + iscomplex[iv - 1] = ip; + --iv; + // back-transform and normalization is done below + } + } + if (nb > 1) { + // -------------------------------------------------------- + // Blocked version of back-transform + // For complex case, KI2 includes both vectors (KI-1 and KI) + if (ip == 0) { + ki2 = ki; + } else { + ki2 = ki - 1; + } + // Columns IV:NB of work are valid vectors. + // When the number of vectors stored reaches NB-1 or NB, + // or if this was last vector, do the GEMM + if (iv <= 2 || ki2 == 1) { + i__2 = nb - iv + 1; + i__3 = ki2 + nb - iv; + dgemm_("N", "N", n, &i__2, &i__3, &c_b29, &vr[vr_offset], + ldvr, &work[iv * *n + 1], n, &c_b17, &work[(nb + + iv) * *n + 1], n); + // normalize vectors + i__2 = nb; + for (k = iv; k <= i__2; ++k) { + if (iscomplex[k - 1] == 0) { + // real eigenvector + ii = idamax_(n, &work[(nb + k) * *n + 1], &c__1); + remax = 1. / (d__1 = work[ii + (nb + k) * *n], + abs(d__1)); + } else if (iscomplex[k - 1] == 1) { + // first eigenvector of conjugate pair + emax = 0.; + i__3 = *n; + for (ii = 1; ii <= i__3; ++ii) { + // Computing MAX + d__3 = emax, d__4 = (d__1 = work[ii + (nb + k) + * *n], abs(d__1)) + (d__2 = work[ii + + (nb + k + 1) * *n], abs(d__2)); + emax = max(d__3,d__4); + } + remax = 1. / emax; + // else if ISCOMPLEX(K).EQ.-1 + // second eigenvector of conjugate pair + // reuse same REMAX as previous K + } + dscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1); + } + i__2 = nb - iv + 1; + dlacpy_("F", n, &i__2, &work[(nb + iv) * *n + 1], n, &vr[ + ki2 * vr_dim1 + 1], ldvr); + iv = nb; + } else { + --iv; + } + } + // + // blocked back-transform + --is; + if (ip != 0) { + --is; + } +L140: + ; + } + } + if (leftv) { + // + // ============================================================ + // Compute left eigenvectors. + // + // IV is index of column in current block. + // For complex left vector, uses IV for real part and IV+1 for complex part. + // Non-blocked version always uses IV=1; + // blocked version starts with IV=1, goes up to NB-1 or NB. + // (Note the "0-th" column is used for 1-norms computed above.) + iv = 1; + ip = 0; + is = 1; + i__2 = *n; + for (ki = 1; ki <= i__2; ++ki) { + if (ip == 1) { + // previous iteration (ki-1) was first of conjugate pair, + // so this ki is second of conjugate pair; skip to end of loop + ip = -1; + goto L260; + } else if (ki == *n) { + // last column, so this ki must be real eigenvalue + ip = 0; + } else if (t[ki + 1 + ki * t_dim1] == 0.) { + // zero on sub-diagonal, so this ki is real eigenvalue + ip = 0; + } else { + // non-zero on sub-diagonal, so this ki is first of conjugate pair + ip = 1; + } + if (somev) { + if (! select[ki]) { + goto L260; + } + } + // + // Compute the KI-th eigenvalue (WR,WI). + // + wr = t[ki + ki * t_dim1]; + wi = 0.; + if (ip != 0) { + wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) * + sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2))); + } + // Computing MAX + d__1 = ulp * (abs(wr) + abs(wi)); + smin = max(d__1,smlnum); + if (ip == 0) { + // + // -------------------------------------------------------- + // Real left eigenvector + // + work[ki + iv * *n] = 1.; + // + // Form right-hand side. + // + i__3 = *n; + for (k = ki + 1; k <= i__3; ++k) { + work[k + iv * *n] = -t[ki + k * t_dim1]; +// L160: + } + // + // Solve transposed quasi-triangular system: + // [ T(KI+1:N,KI+1:N) - WR ]**T * X = SCALE*WORK + // + vmax = 1.; + vcrit = bignum; + jnxt = ki + 1; + i__3 = *n; + for (j = ki + 1; j <= i__3; ++j) { + if (j < jnxt) { + goto L170; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnxt = j + 2; + } + } + if (j1 == j2) { + // + // 1-by-1 diagonal block + // + // Scale if necessary to avoid overflow when forming + // the right-hand side. + // + if (work[j] > vcrit) { + rec = 1. / vmax; + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + vmax = 1.; + vcrit = bignum; + } + i__4 = j - ki - 1; + work[j + iv * *n] -= ddot_(&i__4, &t[ki + 1 + j * + t_dim1], &c__1, &work[ki + 1 + iv * *n], & + c__1); + // + // Solve [ T(J,J) - WR ]**T * X = WORK + // + dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + // + // Scale if necessary + // + if (scale != 1.) { + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + } + work[j + iv * *n] = x[0]; + // Computing MAX + d__2 = (d__1 = work[j + iv * *n], abs(d__1)); + vmax = max(d__2,vmax); + vcrit = bignum / vmax; + } else { + // + // 2-by-2 diagonal block + // + // Scale if necessary to avoid overflow when forming + // the right-hand side. + // + // Computing MAX + d__1 = work[j], d__2 = work[j + 1]; + beta = max(d__1,d__2); + if (beta > vcrit) { + rec = 1. / vmax; + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + vmax = 1.; + vcrit = bignum; + } + i__4 = j - ki - 1; + work[j + iv * *n] -= ddot_(&i__4, &t[ki + 1 + j * + t_dim1], &c__1, &work[ki + 1 + iv * *n], & + c__1); + i__4 = j - ki - 1; + work[j + 1 + iv * *n] -= ddot_(&i__4, &t[ki + 1 + (j + + 1) * t_dim1], &c__1, &work[ki + 1 + iv * *n] + , &c__1); + // + // Solve + // [ T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) + // [ T(J+1,J) T(J+1,J+1)-WR ] ( WORK2 ) + // + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + // + // Scale if necessary + // + if (scale != 1.) { + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + } + work[j + iv * *n] = x[0]; + work[j + 1 + iv * *n] = x[1]; + // + // Computing MAX + d__3 = (d__1 = work[j + iv * *n], abs(d__1)), d__4 = ( + d__2 = work[j + 1 + iv * *n], abs(d__2)), + d__3 = max(d__3,d__4); + vmax = max(d__3,vmax); + vcrit = bignum / vmax; + } +L170: + ; + } + // + // Copy the vector x or Q*x to VL and normalize. + // + if (! over) { + // ------------------------------ + // no back-transform: copy x to VL and normalize. + i__3 = *n - ki + 1; + dcopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + i__3 = *n - ki + 1; + ii = idamax_(&i__3, &vl[ki + is * vl_dim1], &c__1) + ki - + 1; + remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1)); + i__3 = *n - ki + 1; + dscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1); + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + vl[k + is * vl_dim1] = 0.; +// L180: + } + } else if (nb == 1) { + // ------------------------------ + // version 1: back-transform each vector with GEMV, Q*x. + if (ki < *n) { + i__3 = *n - ki; + dgemv_("N", n, &i__3, &c_b29, &vl[(ki + 1) * vl_dim1 + + 1], ldvl, &work[ki + 1 + iv * *n], &c__1, & + work[ki + iv * *n], &vl[ki * vl_dim1 + 1], & + c__1); + } + ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1); + remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1)); + dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + } else { + // ------------------------------ + // version 2: back-transform block of vectors with GEMM + // zero out above vector + // could go from KI-NV+1 to KI-1 + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + work[k + iv * *n] = 0.; + } + iscomplex[iv - 1] = ip; + // back-transform and normalization is done below + } + } else { + // + // -------------------------------------------------------- + // Complex left eigenvector. + // + // Initial solve: + // [ ( T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI) ]*X = 0. + // [ ( T(KI+1,KI) T(KI+1,KI+1) ) ] + // + if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >= (d__2 = + t[ki + 1 + ki * t_dim1], abs(d__2))) { + work[ki + iv * *n] = wi / t[ki + (ki + 1) * t_dim1]; + work[ki + 1 + (iv + 1) * *n] = 1.; + } else { + work[ki + iv * *n] = 1.; + work[ki + 1 + (iv + 1) * *n] = -wi / t[ki + 1 + ki * + t_dim1]; + } + work[ki + 1 + iv * *n] = 0.; + work[ki + (iv + 1) * *n] = 0.; + // + // Form right-hand side. + // + i__3 = *n; + for (k = ki + 2; k <= i__3; ++k) { + work[k + iv * *n] = -work[ki + iv * *n] * t[ki + k * + t_dim1]; + work[k + (iv + 1) * *n] = -work[ki + 1 + (iv + 1) * *n] * + t[ki + 1 + k * t_dim1]; +// L190: + } + // + // Solve transposed quasi-triangular system: + // [ T(KI+2:N,KI+2:N)**T - (WR-i*WI) ]*X = WORK1+i*WORK2 + // + vmax = 1.; + vcrit = bignum; + jnxt = ki + 2; + i__3 = *n; + for (j = ki + 2; j <= i__3; ++j) { + if (j < jnxt) { + goto L200; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnxt = j + 2; + } + } + if (j1 == j2) { + // + // 1-by-1 diagonal block + // + // Scale if necessary to avoid overflow when + // forming the right-hand side elements. + // + if (work[j] > vcrit) { + rec = 1. / vmax; + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + (iv + 1) * *n], & + c__1); + vmax = 1.; + vcrit = bignum; + } + i__4 = j - ki - 2; + work[j + iv * *n] -= ddot_(&i__4, &t[ki + 2 + j * + t_dim1], &c__1, &work[ki + 2 + iv * *n], & + c__1); + i__4 = j - ki - 2; + work[j + (iv + 1) * *n] -= ddot_(&i__4, &t[ki + 2 + j + * t_dim1], &c__1, &work[ki + 2 + (iv + 1) * * + n], &c__1); + // + // Solve [ T(J,J)-(WR-i*WI) ]*(X11+i*X12)= WK+I*WK2 + // + d__1 = -wi; + dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &d__1, x, &c__2, &scale, & + xnorm, &ierr); + // + // Scale if necessary + // + if (scale != 1.) { + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + (iv + 1) * *n], & + c__1); + } + work[j + iv * *n] = x[0]; + work[j + (iv + 1) * *n] = x[2]; + // Computing MAX + d__3 = (d__1 = work[j + iv * *n], abs(d__1)), d__4 = ( + d__2 = work[j + (iv + 1) * *n], abs(d__2)), + d__3 = max(d__3,d__4); + vmax = max(d__3,vmax); + vcrit = bignum / vmax; + } else { + // + // 2-by-2 diagonal block + // + // Scale if necessary to avoid overflow when forming + // the right-hand side elements. + // + // Computing MAX + d__1 = work[j], d__2 = work[j + 1]; + beta = max(d__1,d__2); + if (beta > vcrit) { + rec = 1. / vmax; + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + (iv + 1) * *n], & + c__1); + vmax = 1.; + vcrit = bignum; + } + i__4 = j - ki - 2; + work[j + iv * *n] -= ddot_(&i__4, &t[ki + 2 + j * + t_dim1], &c__1, &work[ki + 2 + iv * *n], & + c__1); + i__4 = j - ki - 2; + work[j + (iv + 1) * *n] -= ddot_(&i__4, &t[ki + 2 + j + * t_dim1], &c__1, &work[ki + 2 + (iv + 1) * * + n], &c__1); + i__4 = j - ki - 2; + work[j + 1 + iv * *n] -= ddot_(&i__4, &t[ki + 2 + (j + + 1) * t_dim1], &c__1, &work[ki + 2 + iv * *n] + , &c__1); + i__4 = j - ki - 2; + work[j + 1 + (iv + 1) * *n] -= ddot_(&i__4, &t[ki + 2 + + (j + 1) * t_dim1], &c__1, &work[ki + 2 + ( + iv + 1) * *n], &c__1); + // + // Solve 2-by-2 complex linear equation + // [ (T(j,j) T(j,j+1) )**T - (wr-i*wi)*I ]*X = SCALE*B + // [ (T(j+1,j) T(j+1,j+1)) ] + // + d__1 = -wi; + dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &d__1, x, &c__2, &scale, & + xnorm, &ierr); + // + // Scale if necessary + // + if (scale != 1.) { + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + (iv + 1) * *n], & + c__1); + } + work[j + iv * *n] = x[0]; + work[j + (iv + 1) * *n] = x[2]; + work[j + 1 + iv * *n] = x[1]; + work[j + 1 + (iv + 1) * *n] = x[3]; + // Computing MAX + d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = max(d__1, + d__2), d__2 = abs(x[1]), d__1 = max(d__1,d__2) + , d__2 = abs(x[3]), d__1 = max(d__1,d__2); + vmax = max(d__1,vmax); + vcrit = bignum / vmax; + } +L200: + ; + } + // + // Copy the vector x or Q*x to VL and normalize. + // + if (! over) { + // ------------------------------ + // no back-transform: copy x to VL and normalize. + i__3 = *n - ki + 1; + dcopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + i__3 = *n - ki + 1; + dcopy_(&i__3, &work[ki + (iv + 1) * *n], &c__1, &vl[ki + ( + is + 1) * vl_dim1], &c__1); + emax = 0.; + i__3 = *n; + for (k = ki; k <= i__3; ++k) { + // Computing MAX + d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs( + d__1)) + (d__2 = vl[k + (is + 1) * vl_dim1], + abs(d__2)); + emax = max(d__3,d__4); +// L220: + } + remax = 1. / emax; + i__3 = *n - ki + 1; + dscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1) + ; + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + vl[k + is * vl_dim1] = 0.; + vl[k + (is + 1) * vl_dim1] = 0.; +// L230: + } + } else if (nb == 1) { + // ------------------------------ + // version 1: back-transform each vector with GEMV, Q*x. + if (ki < *n - 1) { + i__3 = *n - ki - 1; + dgemv_("N", n, &i__3, &c_b29, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + iv * *n], &c__1, & + work[ki + iv * *n], &vl[ki * vl_dim1 + 1], & + c__1); + i__3 = *n - ki - 1; + dgemv_("N", n, &i__3, &c_b29, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + (iv + 1) * *n], & + c__1, &work[ki + 1 + (iv + 1) * *n], &vl[(ki + + 1) * vl_dim1 + 1], &c__1); + } else { + dscal_(n, &work[ki + iv * *n], &vl[ki * vl_dim1 + 1], + &c__1); + dscal_(n, &work[ki + 1 + (iv + 1) * *n], &vl[(ki + 1) + * vl_dim1 + 1], &c__1); + } + emax = 0.; + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + // Computing MAX + d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs( + d__1)) + (d__2 = vl[k + (ki + 1) * vl_dim1], + abs(d__2)); + emax = max(d__3,d__4); +// L240: + } + remax = 1. / emax; + dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1); + } else { + // ------------------------------ + // version 2: back-transform block of vectors with GEMM + // zero out above vector + // could go from KI-NV+1 to KI-1 + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + work[k + iv * *n] = 0.; + work[k + (iv + 1) * *n] = 0.; + } + iscomplex[iv - 1] = ip; + iscomplex[iv] = -ip; + ++iv; + // back-transform and normalization is done below + } + } + if (nb > 1) { + // -------------------------------------------------------- + // Blocked version of back-transform + // For complex case, KI2 includes both vectors (KI and KI+1) + if (ip == 0) { + ki2 = ki; + } else { + ki2 = ki + 1; + } + // Columns 1:IV of work are valid vectors. + // When the number of vectors stored reaches NB-1 or NB, + // or if this was last vector, do the GEMM + if (iv >= nb - 1 || ki2 == *n) { + i__3 = *n - ki2 + iv; + dgemm_("N", "N", n, &iv, &i__3, &c_b29, &vl[(ki2 - iv + 1) + * vl_dim1 + 1], ldvl, &work[ki2 - iv + 1 + *n], + n, &c_b17, &work[(nb + 1) * *n + 1], n); + // normalize vectors + i__3 = iv; + for (k = 1; k <= i__3; ++k) { + if (iscomplex[k - 1] == 0) { + // real eigenvector + ii = idamax_(n, &work[(nb + k) * *n + 1], &c__1); + remax = 1. / (d__1 = work[ii + (nb + k) * *n], + abs(d__1)); + } else if (iscomplex[k - 1] == 1) { + // first eigenvector of conjugate pair + emax = 0.; + i__4 = *n; + for (ii = 1; ii <= i__4; ++ii) { + // Computing MAX + d__3 = emax, d__4 = (d__1 = work[ii + (nb + k) + * *n], abs(d__1)) + (d__2 = work[ii + + (nb + k + 1) * *n], abs(d__2)); + emax = max(d__3,d__4); + } + remax = 1. / emax; + // else if ISCOMPLEX(K).EQ.-1 + // second eigenvector of conjugate pair + // reuse same REMAX as previous K + } + dscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1); + } + dlacpy_("F", n, &iv, &work[(nb + 1) * *n + 1], n, &vl[( + ki2 - iv + 1) * vl_dim1 + 1], ldvl); + iv = 1; + } else { + ++iv; + } + } + // + // blocked back-transform + ++is; + if (ip != 0) { + ++is; + } +L260: + ; + } + } + return 0; + // + // End of DTREVC3 + // +} // dtrevc3_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DTREXC +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DTREXC + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, +// INFO ) +// +// .. Scalar Arguments .. +// CHARACTER COMPQ +// INTEGER IFST, ILST, INFO, LDQ, LDT, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DTREXC reorders the real Schur factorization of a real matrix +//> A = Q*T*Q**T, so that the diagonal block of T with row index IFST is +//> moved to row ILST. +//> +//> The real Schur form T is reordered by an orthogonal similarity +//> transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors +//> is updated by postmultiplying it with Z. +//> +//> T must be in Schur canonical form (as returned by DHSEQR), that is, +//> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each +//> 2-by-2 diagonal block has its diagonal elements equal and its +//> off-diagonal elements of opposite sign. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] COMPQ +//> \verbatim +//> COMPQ is CHARACTER*1 +//> = 'V': update the matrix Q of Schur vectors; +//> = 'N': do not update Q. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix T. N >= 0. +//> If N == 0 arguments ILST and IFST may be any value. +//> \endverbatim +//> +//> \param[in,out] T +//> \verbatim +//> T is DOUBLE PRECISION array, dimension (LDT,N) +//> On entry, the upper quasi-triangular matrix T, in Schur +//> Schur canonical form. +//> On exit, the reordered upper quasi-triangular matrix, again +//> in Schur canonical form. +//> \endverbatim +//> +//> \param[in] LDT +//> \verbatim +//> LDT is INTEGER +//> The leading dimension of the array T. LDT >= max(1,N). +//> \endverbatim +//> +//> \param[in,out] Q +//> \verbatim +//> Q is DOUBLE PRECISION array, dimension (LDQ,N) +//> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. +//> On exit, if COMPQ = 'V', Q has been postmultiplied by the +//> orthogonal transformation matrix Z which reorders T. +//> If COMPQ = 'N', Q is not referenced. +//> \endverbatim +//> +//> \param[in] LDQ +//> \verbatim +//> LDQ is INTEGER +//> The leading dimension of the array Q. LDQ >= 1, and if +//> COMPQ = 'V', LDQ >= max(1,N). +//> \endverbatim +//> +//> \param[in,out] IFST +//> \verbatim +//> IFST is INTEGER +//> \endverbatim +//> +//> \param[in,out] ILST +//> \verbatim +//> ILST is INTEGER +//> +//> Specify the reordering of the diagonal blocks of T. +//> The block with row index IFST is moved to row ILST, by a +//> sequence of transpositions between adjacent blocks. +//> On exit, if IFST pointed on entry to the second row of a +//> 2-by-2 block, it is changed to point to the first row; ILST +//> always points to the first row of the block in its final +//> position (which may differ from its input value by +1 or -1). +//> 1 <= IFST <= N; 1 <= ILST <= N. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (N) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> = 1: two adjacent blocks were too close to swap (the problem +//> is very ill-conditioned); T may have been partially +//> reordered, and ILST points to the first row of the +//> current position of the block being moved. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dtrexc_(char *compq, int *n, double *t, int *ldt, double + *q, int *ldq, int *ifst, int *ilst, double *work, int *info) +{ + // Table of constant values + int c__1 = 1; + int c__2 = 2; + + // System generated locals + int q_dim1, q_offset, t_dim1, t_offset, i__1; + + // Local variables + int nbf, nbl, here; + extern int lsame_(char *, char *); + int wantq; + extern /* Subroutine */ int dlaexc_(int *, int *, double *, int *, double + *, int *, int *, int *, int *, double *, int *), xerbla_(char *, + int *); + int nbnext; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Decode and test the input arguments. + // + // Parameter adjustments + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --work; + + // Function Body + *info = 0; + wantq = lsame_(compq, "V"); + if (! wantq && ! lsame_(compq, "N")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldt < max(1,*n)) { + *info = -4; + } else if (*ldq < 1 || wantq && *ldq < max(1,*n)) { + *info = -6; + } else if ((*ifst < 1 || *ifst > *n) && *n > 0) { + *info = -7; + } else if ((*ilst < 1 || *ilst > *n) && *n > 0) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTREXC", &i__1); + return 0; + } + // + // Quick return if possible + // + if (*n <= 1) { + return 0; + } + // + // Determine the first row of specified block + // and find out it is 1 by 1 or 2 by 2. + // + if (*ifst > 1) { + if (t[*ifst + (*ifst - 1) * t_dim1] != 0.) { + --(*ifst); + } + } + nbf = 1; + if (*ifst < *n) { + if (t[*ifst + 1 + *ifst * t_dim1] != 0.) { + nbf = 2; + } + } + // + // Determine the first row of the final block + // and find out it is 1 by 1 or 2 by 2. + // + if (*ilst > 1) { + if (t[*ilst + (*ilst - 1) * t_dim1] != 0.) { + --(*ilst); + } + } + nbl = 1; + if (*ilst < *n) { + if (t[*ilst + 1 + *ilst * t_dim1] != 0.) { + nbl = 2; + } + } + if (*ifst == *ilst) { + return 0; + } + if (*ifst < *ilst) { + // + // Update ILST + // + if (nbf == 2 && nbl == 1) { + --(*ilst); + } + if (nbf == 1 && nbl == 2) { + ++(*ilst); + } + here = *ifst; +L10: + // + // Swap block with next one below + // + if (nbf == 1 || nbf == 2) { + // + // Current block either 1 by 1 or 2 by 2 + // + nbnext = 1; + if (here + nbf + 1 <= *n) { + if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) { + nbnext = 2; + } + } + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, & + nbf, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += nbnext; + // + // Test if 2 by 2 block breaks into two 1 by 1 blocks + // + if (nbf == 2) { + if (t[here + 1 + here * t_dim1] == 0.) { + nbf = 3; + } + } + } else { + // + // Current block consists of two 1 by 1 blocks each of which + // must be swapped individually + // + nbnext = 1; + if (here + 3 <= *n) { + if (t[here + 3 + (here + 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here + 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + c__1, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + // + // Swap two 1 by 1 blocks, no problems possible + // + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &nbnext, &work[1], info); + ++here; + } else { + // + // Recompute NBNEXT in case 2 by 2 split + // + if (t[here + 2 + (here + 1) * t_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + // + // 2 by 2 Block did not split + // + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += 2; + } else { + // + // 2 by 2 Block did split + // + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &c__1, &work[1], info); + i__1 = here + 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__1, &c__1, &work[1], info); + here += 2; + } + } + } + if (here < *ilst) { + goto L10; + } + } else { + here = *ifst; +L20: + // + // Swap block with next one above + // + if (nbf == 1 || nbf == 2) { + // + // Current block either 1 by 1 or 2 by 2 + // + nbnext = 1; + if (here >= 3) { + if (t[here - 1 + (here - 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + nbnext, &nbf, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here -= nbnext; + // + // Test if 2 by 2 block breaks into two 1 by 1 blocks + // + if (nbf == 2) { + if (t[here + 1 + here * t_dim1] == 0.) { + nbf = 3; + } + } + } else { + // + // Current block consists of two 1 by 1 blocks each of which + // must be swapped individually + // + nbnext = 1; + if (here >= 3) { + if (t[here - 1 + (here - 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + nbnext, &c__1, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + // + // Swap two 1 by 1 blocks, no problems possible + // + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &nbnext, &c__1, &work[1], info); + --here; + } else { + // + // Recompute NBNEXT in case 2 by 2 split + // + if (t[here + (here - 1) * t_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + // + // 2 by 2 Block did not split + // + i__1 = here - 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__2, &c__1, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += -2; + } else { + // + // 2 by 2 Block did split + // + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &c__1, &work[1], info); + i__1 = here - 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__1, &c__1, &work[1], info); + here += -2; + } + } + } + if (here > *ilst) { + goto L20; + } + } + *ilst = here; + return 0; + // + // End of DTREXC + // +} // dtrexc_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b IDAMAX +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// INTEGER FUNCTION IDAMAX(N,DX,INCX) +// +// .. Scalar Arguments .. +// INTEGER INCX,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION DX(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> IDAMAX finds the index of the first element having maximum absolute value. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> number of elements in input vector(s) +//> \endverbatim +//> +//> \param[in] DX +//> \verbatim +//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> storage spacing between elements of DX +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup aux_blas +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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(*) +//> \endverbatim +//> +// ===================================================================== +int idamax_(int *n, double *dx, int *incx) +{ + // System generated locals + int ret_val, i__1; + double d__1; + + // Local variables + int i__, ix; + double dmax__; + + // + // -- Reference BLAS level1 routine (version 3.8.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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) { + // + // code for increment equal to 1 + // + dmax__ = abs(dx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[i__], abs(d__1)) > dmax__) { + ret_val = i__; + dmax__ = (d__1 = dx[i__], abs(d__1)); + } + } + } else { + // + // 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__) { + ret_val = i__; + dmax__ = (d__1 = dx[ix], abs(d__1)); + } + ix += *incx; + } + } + return ret_val; +} // idamax_ + diff --git a/3rdparty/clapack/src/dgemm.c b/3rdparty/clapack/src/dgemm.c new file mode 100644 index 0000000000..cc0533cf54 --- /dev/null +++ b/3rdparty/clapack/src/dgemm.c @@ -0,0 +1,444 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DGEMM +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION ALPHA,BETA +// INTEGER K,LDA,LDB,LDC,M,N +// CHARACTER TRANSA,TRANSB +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T, +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] TRANSA +//> \verbatim +//> TRANSA is 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**T. +//> +//> TRANSA = 'C' or 'c', op( A ) = A**T. +//> \endverbatim +//> +//> \param[in] TRANSB +//> \verbatim +//> TRANSB is 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**T. +//> +//> TRANSB = 'C' or 'c', op( B ) = B**T. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is 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. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is 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. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is 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. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION. +//> On entry, ALPHA specifies the scalar alpha. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is 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 ). +//> \endverbatim +//> +//> \param[in] B +//> \verbatim +//> B is DOUBLE PRECISION array, 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. +//> \endverbatim +//> +//> \param[in] LDB +//> \verbatim +//> LDB is 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 ). +//> \endverbatim +//> +//> \param[in] BETA +//> \verbatim +//> BETA is DOUBLE PRECISION. +//> On entry, BETA specifies the scalar beta. When BETA is +//> supplied as zero then C need not be set on input. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is DOUBLE PRECISION array, 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 ). +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is 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 ). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup double_blas_level3 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgemm_(char *transa, char *transb, int *m, int *n, int * + k, double *alpha, double *a, int *lda, double *b, int *ldb, double * + beta, double *c__, int *ldc) +{ + // System generated locals + int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + // Local variables + int i__, j, l, info; + int nota, notb; + double temp; + int ncola; + extern int lsame_(char *, char *); + int nrowa, nrowb; + extern /* Subroutine */ int xerbla_(char *, int *); + + // + // -- Reference BLAS level3 routine (version 3.7.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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) { + 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**T*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**T + 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) { + 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**T*B**T + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; +// L180: + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +// L190: + } +// L200: + } + } + } + return 0; + // + // End of DGEMM . + // +} // dgemm_ + diff --git a/3rdparty/clapack/src/dgemv.c b/3rdparty/clapack/src/dgemv.c new file mode 100644 index 0000000000..4b812cecee --- /dev/null +++ b/3rdparty/clapack/src/dgemv.c @@ -0,0 +1,370 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DGEMV +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION ALPHA,BETA +// INTEGER INCX,INCY,LDA,M,N +// CHARACTER TRANS +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A(LDA,*),X(*),Y(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEMV performs one of the matrix-vector operations +//> +//> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +//> +//> where alpha and beta are scalars, x and y are vectors and A is an +//> m by n matrix. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] TRANS +//> \verbatim +//> TRANS is 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**T*x + beta*y. +//> +//> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> On entry, M specifies the number of rows of the matrix A. +//> M must be at least zero. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> On entry, N specifies the number of columns of the matrix A. +//> N must be at least zero. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION. +//> On entry, ALPHA specifies the scalar alpha. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension ( LDA, N ) +//> Before entry, the leading m by n part of the array A must +//> contain the matrix of coefficients. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is 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 ). +//> \endverbatim +//> +//> \param[in] X +//> \verbatim +//> X is DOUBLE PRECISION array, 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. +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> On entry, INCX specifies the increment for the elements of +//> X. INCX must not be zero. +//> \endverbatim +//> +//> \param[in] BETA +//> \verbatim +//> BETA is DOUBLE PRECISION. +//> On entry, BETA specifies the scalar beta. When BETA is +//> supplied as zero then Y need not be set on input. +//> \endverbatim +//> +//> \param[in,out] Y +//> \verbatim +//> Y is DOUBLE PRECISION array, 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. +//> \endverbatim +//> +//> \param[in] INCY +//> \verbatim +//> INCY is INTEGER +//> On entry, INCY specifies the increment for the elements of +//> Y. INCY must not be zero. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup double_blas_level2 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> Level 2 Blas routine. +//> The vector and matrix arguments are not referenced when N = 0, or M = 0 +//> +//> -- 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgemv_(char *trans, int *m, int *n, double *alpha, + double *a, int *lda, double *x, int *incx, double *beta, double *y, + int *incy) +{ + // System generated locals + int a_dim1, a_offset, i__1, i__2; + + // Local variables + int i__, j, ix, iy, jx, jy, kx, ky, info; + double temp; + int lenx, leny; + extern int lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, int *); + + // + // -- Reference BLAS level2 routine (version 3.7.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(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_("DGEMV ", &info); + return 0; + } + // + // Quick return if possible. + // + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + // + // Set LENX and LENY, the lengths of the vectors x and y, and set + // up the start points in X and Y. + // + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + // + // Start the operations. In this version the elements of A are + // accessed sequentially with one pass through A. + // + // First form y := beta*y. + // + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +// L10: + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +// L20: + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +// L30: + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +// L40: + } + } + } + } + if (*alpha == 0.) { + return 0; + } + if (lsame_(trans, "N")) { + // + // Form y := alpha*A*x + y. + // + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha * x[jx]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp * a[i__ + j * a_dim1]; +// L50: + } + jx += *incx; +// L60: + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha * x[jx]; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp * a[i__ + j * a_dim1]; + iy += *incy; +// L70: + } + jx += *incx; +// L80: + } + } + } else { + // + // Form y := alpha*A**T*x + y. + // + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +// L90: + } + y[jy] += *alpha * temp; + jy += *incy; +// L100: + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; +// L110: + } + y[jy] += *alpha * temp; + jy += *incy; +// L120: + } + } + } + return 0; + // + // End of DGEMV . + // +} // dgemv_ + diff --git a/3rdparty/clapack/src/dgesdd.c b/3rdparty/clapack/src/dgesdd.c new file mode 100644 index 0000000000..267cf27df3 --- /dev/null +++ b/3rdparty/clapack/src/dgesdd.c @@ -0,0 +1,18599 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DBDSDC +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DBDSDC + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, +// WORK, IWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER COMPQ, UPLO +// INTEGER INFO, LDU, LDVT, N +// .. +// .. Array Arguments .. +// INTEGER IQ( * ), IWORK( * ) +// DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ), +// $ VT( LDVT, * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] UPLO +//> \verbatim +//> UPLO is CHARACTER*1 +//> = 'U': B is upper bidiagonal. +//> = 'L': B is lower bidiagonal. +//> \endverbatim +//> +//> \param[in] COMPQ +//> \verbatim +//> COMPQ is 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. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix B. N >= 0. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[in,out] E +//> \verbatim +//> E is 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. +//> \endverbatim +//> +//> \param[out] U +//> \verbatim +//> U is 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. +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER +//> The leading dimension of the array U. LDU >= 1. +//> If singular vectors are desired, then LDU >= max( 1, N ). +//> \endverbatim +//> +//> \param[out] VT +//> \verbatim +//> VT is DOUBLE PRECISION array, dimension (LDVT,N) +//> If COMPQ = 'I', then: +//> On exit, if INFO = 0, VT**T contains the right singular +//> vectors of the bidiagonal matrix. +//> For other values of COMPQ, VT is not referenced. +//> \endverbatim +//> +//> \param[in] LDVT +//> \verbatim +//> LDVT is INTEGER +//> The leading dimension of the array VT. LDVT >= 1. +//> If singular vectors are desired, then LDVT >= max( 1, N ). +//> \endverbatim +//> +//> \param[out] Q +//> \verbatim +//> Q is 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. +//> \endverbatim +//> +//> \param[out] IQ +//> \verbatim +//> IQ is 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. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is 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). +//> \endverbatim +//> +//> \param[out] IWORK +//> \verbatim +//> IWORK is INTEGER array, dimension (8*N) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: The algorithm failed to compute a singular value. +//> The update process of divide and conquer failed. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup auxOTHERcomputational +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dbdsdc_(char *uplo, char *compq, int *n, double *d__, + double *e, double *u, int *ldu, double *vt, int *ldvt, double *q, int + *iq, double *work, int *iwork, int *info) +{ + // Table of constant values + int c__9 = 9; + int c__0 = 0; + double c_b15 = 1.; + int c__1 = 1; + double c_b29 = 0.; + + // System generated locals + int u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + double d__1; + + // Local variables + int i__, j, k; + double p, r__; + int z__, ic, ii, kk; + double cs; + int is, iu; + double sn; + int nm1; + double eps; + int ivt, difl, difr, ierr, perm, mlvl, sqre; + extern int lsame_(char *, char *); + extern /* Subroutine */ int dlasr_(char *, char *, char *, int *, int *, + double *, double *, double *, int *), dcopy_(int *, double *, int + *, double *, int *), dswap_(int *, double *, int *, double *, int + *); + int poles, iuplo, nsize, start; + extern /* Subroutine */ int dlasd0_(int *, int *, double *, double *, + double *, int *, double *, int *, int *, int *, double *, int *); + extern double dlamch_(char *); + extern /* Subroutine */ int dlasda_(int *, int *, int *, int *, double *, + double *, double *, int *, double *, int *, double *, double *, + double *, double *, int *, int *, int *, int *, double *, double * + , double *, double *, int *, int *), dlascl_(char *, int *, int *, + double *, double *, int *, int *, double *, int *, int *), + dlasdq_(char *, int *, int *, int *, int *, int *, double *, + double *, double *, int *, double *, int *, double *, int *, + double *, int *), dlaset_(char *, int *, int *, double *, double * + , double *, int *), dlartg_(double *, double *, double *, double * + , double *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + extern /* Subroutine */ int xerbla_(char *, int *); + int givcol; + extern double dlanst_(char *, int *, double *, double *); + int icompq; + double orgnrm; + int givnum, givptr, qstart, smlsiz, wstart, smlszp; + + // + // -- LAPACK computational routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // 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; + if (icompq == 2) { + 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) { + // Ignore WSTART, instead using WORK( 1 ), since the two vectors + // for CS and -SN above are added only if ICOMPQ == 2, + // and adding them exceeds documented WORK size of 4*n. + 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[ + 1], 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") * .9; + mlvl = (int) (log((double) (*n) / (double) (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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DBDSQR +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DBDSQR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, +// LDU, C, LDC, WORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER UPLO +// INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU +// .. +// .. Array Arguments .. +// DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), +// $ VT( LDVT, * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] UPLO +//> \verbatim +//> UPLO is CHARACTER*1 +//> = 'U': B is upper bidiagonal; +//> = 'L': B is lower bidiagonal. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix B. N >= 0. +//> \endverbatim +//> +//> \param[in] NCVT +//> \verbatim +//> NCVT is INTEGER +//> The number of columns of the matrix VT. NCVT >= 0. +//> \endverbatim +//> +//> \param[in] NRU +//> \verbatim +//> NRU is INTEGER +//> The number of rows of the matrix U. NRU >= 0. +//> \endverbatim +//> +//> \param[in] NCC +//> \verbatim +//> NCC is INTEGER +//> The number of columns of the matrix C. NCC >= 0. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[in,out] E +//> \verbatim +//> E is 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. +//> \endverbatim +//> +//> \param[in,out] VT +//> \verbatim +//> VT is 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. +//> \endverbatim +//> +//> \param[in] LDVT +//> \verbatim +//> LDVT is INTEGER +//> The leading dimension of the array VT. +//> LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. +//> \endverbatim +//> +//> \param[in,out] U +//> \verbatim +//> U is 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. +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER +//> The leading dimension of the array U. LDU >= max(1,NRU). +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. +//> LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (4*(N-1)) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is 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. +//> \endverbatim +// +//> \par Internal Parameters: +// ========================= +//> +//> \verbatim +//> 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. +//> +//> \endverbatim +// +//> \par Note: +// =========== +//> +//> \verbatim +//> Bug report from Cezary Dendek. +//> On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is +//> removed since it can overflow pretty easily (for N larger or equal +//> than 18,919). We instead use MAXITDIVN = MAXITR*N. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup auxOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dbdsqr_(char *uplo, int *n, int *ncvt, int *nru, int * + ncc, double *d__, double *e, double *vt, int *ldvt, double *u, int * + ldu, double *c__, int *ldc, double *work, int *info) +{ + // Table of constant values + double c_b15 = -.125; + int c__1 = 1; + double c_b49 = 1.; + double c_b72 = -1.; + + // System generated locals + int c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + double d__1, d__2, d__3, d__4; + + // Local variables + int iterdivn; + double f, g, h__; + int i__, j, m; + double r__; + int maxitdivn; + double cs; + int ll; + double sn, mu; + int nm1, nm12, nm13, lll; + double eps, sll, tol, abse; + int idir; + double abss; + int oldm; + double cosl; + int isub, iter; + double unfl, sinl, cosr, smin, smax, sinr; + extern /* Subroutine */ int drot_(int *, double *, int *, double *, int *, + double *, double *), dlas2_(double *, double *, double *, double + *, double *), dscal_(int *, double *, double *, int *); + extern int lsame_(char *, char *); + double oldcs; + extern /* Subroutine */ int dlasr_(char *, char *, char *, int *, int *, + double *, double *, double *, int *); + int oldll; + double shift, sigmn, oldsn; + extern /* Subroutine */ int dswap_(int *, double *, int *, double *, int * + ); + double sminl, sigmx; + int lower; + extern /* Subroutine */ int dlasq1_(int *, double *, double *, double *, + int *), dlasv2_(double *, double *, double *, double *, double *, + double *, double *, double *, double *); + extern double dlamch_(char *); + extern /* Subroutine */ int dlartg_(double *, double *, double *, double * + , double *), xerbla_(char *, int *); + double sminoa, thresh; + int rotate; + double tolmul; + + // + // -- LAPACK computational routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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); + // + // If INFO equals 2, dqds didn't finish, try to finish + // + if (*info != 2) { + return 0; + } + *info = 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((double) (*n)); + // Computing MAX + d__1 = tol * sminoa, d__2 = *n * (*n * unfl) * 6; + thresh = max(d__1,d__2); + } else { + // + // Absolute accuracy desired + // + // Computing MAX + d__1 = abs(tol) * smax, d__2 = *n * (*n * unfl) * 6; + 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.) + // + maxitdivn = *n * 6; + iterdivn = 0; + iter = -1; + 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 >= *n) { + iter -= *n; + ++iterdivn; + if (iterdivn >= maxitdivn) { + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEBD2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, LDA, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), +// $ TAUQ( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEBD2 reduces a real general 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows in the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns in the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension (min(M,N)) +//> The diagonal elements of the bidiagonal matrix B: +//> D(i) = A(i,i). +//> \endverbatim +//> +//> \param[out] E +//> \verbatim +//> E is 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. +//> \endverbatim +//> +//> \param[out] TAUQ +//> \verbatim +//> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) +//> The scalar factors of the elementary reflectors which +//> represent the orthogonal matrix Q. See Further Details. +//> \endverbatim +//> +//> \param[out] TAUP +//> \verbatim +//> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) +//> The scalar factors of the elementary reflectors which +//> represent the orthogonal matrix P. See Further Details. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (max(M,N)) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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**T and G(i) = I - taup * u * u**T +//> +//> 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**T and G(i) = I - taup * u * u**T +//> +//> 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). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgebd2_(int *m, int *n, double *a, int *lda, double *d__, + double *e, double *tauq, double *taup, double *work, int *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3; + + // Local variables + int i__; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *), dlarfg_(int *, double *, + double *, int *, double *), xerbla_(char *, int *); + + // + // -- LAPACK computational routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGEBRD +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEBRD + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, +// INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, LDA, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), +// $ TAUQ( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows in the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns in the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension (min(M,N)) +//> The diagonal elements of the bidiagonal matrix B: +//> D(i) = A(i,i). +//> \endverbatim +//> +//> \param[out] E +//> \verbatim +//> E is 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. +//> \endverbatim +//> +//> \param[out] TAUQ +//> \verbatim +//> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) +//> The scalar factors of the elementary reflectors which +//> represent the orthogonal matrix Q. See Further Details. +//> \endverbatim +//> +//> \param[out] TAUP +//> \verbatim +//> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) +//> The scalar factors of the elementary reflectors which +//> represent the orthogonal matrix P. See Further Details. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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**T and G(i) = I - taup * u * u**T +//> +//> 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**T and G(i) = I - taup * u * u**T +//> +//> 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). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgebrd_(int *m, int *n, double *a, int *lda, double *d__, + double *e, double *tauq, double *taup, double *work, int *lwork, int + *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__3 = 3; + int c__2 = 2; + double c_b21 = -1.; + double c_b22 = 1.; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3, i__4; + + // Local variables + int i__, j, nb, nx, ws; + extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *, + double *, double *, int *, double *, int *, double *, double *, + int *); + int nbmin, iinfo, minmn; + extern /* Subroutine */ int dgebd2_(int *, int *, double *, int *, double + *, double *, double *, double *, double *, int *), dlabrd_(int *, + int *, int *, double *, int *, double *, double *, double *, + double *, double *, int *, double *, int *), xerbla_(char *, int * + ); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + int ldwrkx, ldwrky, lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.8.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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] = (double) 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 = 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 = (*m + *n) * nb; + if (*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**T - X*U**T + // + 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] = (double) ws; + return 0; + // + // End of DGEBRD + // +} // dgebrd_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGELQ2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, LDA, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGELQ2 computes an LQ factorization of a real m-by-n matrix A: +//> +//> A = ( L 0 ) * Q +//> +//> where: +//> +//> Q is a n-by-n orthogonal matrix; +//> L is an lower-triangular m-by-m matrix; +//> 0 is a m-by-(n-m) zero matrix, if m < n. +//> +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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). +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +//> The scalar factors of the elementary reflectors (see Further +//> Details). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (M) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2019 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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**T +//> +//> 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). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgelq2_(int *m, int *n, double *a, int *lda, double *tau, + double *work, int *info) +{ + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3; + + // Local variables + int i__, k; + double aii; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *), dlarfg_(int *, double *, + double *, int *, double *), xerbla_(char *, int *); + + // + // -- LAPACK computational routine (version 3.9.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2019 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + dlarfg_(&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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGELQF +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGELQF + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, LDA, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGELQF computes an LQ factorization of a real M-by-N matrix A: +//> +//> A = ( L 0 ) * Q +//> +//> where: +//> +//> Q is a N-by-N orthogonal matrix; +//> L is an lower-triangular M-by-M matrix; +//> 0 is a M-by-(N-M) zero matrix, if M < N. +//> +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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). +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +//> The scalar factors of the elementary reflectors (see Further +//> Details). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2019 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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**T +//> +//> 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). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgelqf_(int *m, int *n, double *a, int *lda, double *tau, + double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__3 = 3; + int c__2 = 2; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3, i__4; + + // Local variables + int i__, k, ib, nb, nx, iws, nbmin, iinfo; + extern /* Subroutine */ int dgelq2_(int *, int *, double *, int *, double + *, double *, int *), dlarfb_(char *, char *, char *, char *, int * + , int *, int *, double *, int *, double *, int *, double *, int *, + double *, int *), dlarft_(char *, char *, int *, int *, double *, + int *, double *, double *, int *), xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + int ldwork, lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.9.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2019 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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] = (double) 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] = (double) iws; + return 0; + // + // End of DGELQF + // +} // dgelqf_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEQR2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, LDA, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEQR2 computes a QR factorization of a real m-by-n matrix A: +//> +//> A = Q * ( R ), +//> ( 0 ) +//> +//> where: +//> +//> Q is a m-by-m orthogonal matrix; +//> R is an upper-triangular n-by-n matrix; +//> 0 is a (m-n)-by-n zero matrix, if m > n. +//> +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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). +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +//> The scalar factors of the elementary reflectors (see Further +//> Details). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (N) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2019 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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**T +//> +//> 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). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgeqr2_(int *m, int *n, double *a, int *lda, double *tau, + double *work, int *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3; + + // Local variables + int i__, k; + double aii; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *), dlarfg_(int *, double *, + double *, int *, double *), xerbla_(char *, int *); + + // + // -- LAPACK computational routine (version 3.9.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2019 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + dlarfg_(&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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGEQRF +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGEQRF + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, LDA, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGEQRF computes a QR factorization of a real M-by-N matrix A: +//> +//> A = Q * ( R ), +//> ( 0 ) +//> +//> where: +//> +//> Q is a M-by-M orthogonal matrix; +//> R is an upper-triangular N-by-N matrix; +//> 0 is a (M-N)-by-N zero matrix, if M > N. +//> +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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). +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +//> The scalar factors of the elementary reflectors (see Further +//> Details). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2019 +// +//> \ingroup doubleGEcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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**T +//> +//> 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). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dgeqrf_(int *m, int *n, double *a, int *lda, double *tau, + double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__3 = 3; + int c__2 = 2; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3, i__4; + + // Local variables + int i__, k, ib, nb, nx, iws, nbmin, iinfo; + extern /* Subroutine */ int dgeqr2_(int *, int *, double *, int *, double + *, double *, int *), dlarfb_(char *, char *, char *, char *, int * + , int *, int *, double *, int *, double *, int *, double *, int *, + double *, int *), dlarft_(char *, char *, int *, int *, double *, + int *, double *, double *, int *), xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + int ldwork, lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.9.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2019 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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] = (double) 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**T 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] = (double) iws; + return 0; + // + // End of DGEQRF + // +} // dgeqrf_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DGESDD +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DGESDD + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, +// WORK, LWORK, IWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER JOBZ +// INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N +// .. +// .. Array Arguments .. +// INTEGER IWORK( * ) +// DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), +// $ VT( LDVT, * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] JOBZ +//> \verbatim +//> JOBZ is 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. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the input matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the input matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] S +//> \verbatim +//> S is DOUBLE PRECISION array, dimension (min(M,N)) +//> The singular values of A, sorted so that S(i) >= S(i+1). +//> \endverbatim +//> +//> \param[out] U +//> \verbatim +//> U is 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. +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER +//> The leading dimension of the array U. LDU >= 1; if +//> JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. +//> \endverbatim +//> +//> \param[out] VT +//> \verbatim +//> VT is 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. +//> \endverbatim +//> +//> \param[in] LDVT +//> \verbatim +//> LDVT is 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). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK; +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the array WORK. LWORK >= 1. +//> If LWORK = -1, a workspace query is assumed. The optimal +//> size for the WORK array is calculated and stored in WORK(1), +//> and no other work except argument checking is performed. +//> +//> Let mx = max(M,N) and mn = min(M,N). +//> If JOBZ = 'N', LWORK >= 3*mn + max( mx, 7*mn ). +//> If JOBZ = 'O', LWORK >= 3*mn + max( mx, 5*mn*mn + 4*mn ). +//> If JOBZ = 'S', LWORK >= 4*mn*mn + 7*mn. +//> If JOBZ = 'A', LWORK >= 4*mn*mn + 6*mn + mx. +//> These are not tight minimums in all cases; see comments inside code. +//> For good performance, LWORK should generally be larger; +//> a query is recommended. +//> \endverbatim +//> +//> \param[out] IWORK +//> \verbatim +//> IWORK is INTEGER array, dimension (8*min(M,N)) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: DBDSDC did not converge, updating process failed. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup doubleGEsing +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dgesdd_(char *jobz, int *m, int *n, double *a, int *lda, + double *s, double *u, int *ldu, double *vt, int *ldvt, double *work, + int *lwork, int *iwork, int *info) +{ + // Table of constant values + int c_n1 = -1; + int c__0 = 0; + double c_b63 = 0.; + int c__1 = 1; + double c_b84 = 1.; + + // System generated locals + int a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2, + i__3; + + // Local variables + int lwork_dorglq_mn__, lwork_dorglq_nn__, lwork_dorgqr_mm__, + lwork_dorgqr_mn__, i__, ie, lwork_dorgbr_p_mm__, il, + lwork_dorgbr_q_nn__, ir, iu, blk; + double dum[1], eps; + int ivt, iscl; + double anrm; + int idum[1], ierr, itau, lwork_dormbr_qln_mm__, lwork_dormbr_qln_mn__, + lwork_dormbr_qln_nn__, lwork_dormbr_prt_mm__, + lwork_dormbr_prt_mn__, lwork_dormbr_prt_nn__; + extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *, + double *, double *, int *, double *, int *, double *, double *, + int *); + extern int lsame_(char *, char *); + int chunk, minmn, wrkbl, itaup, itauq, mnthr; + int wntqa; + int nwork; + int wntqn, wntqo, wntqs; + extern /* Subroutine */ int dbdsdc_(char *, char *, int *, double *, + double *, double *, int *, double *, int *, double *, int *, + double *, int *, int *), dgebrd_(int *, int *, double *, int *, + double *, double *, double *, double *, double *, int *, int *); + extern double dlamch_(char *), dlange_(char *, int *, int *, double *, + int *, double *); + int bdspac; + extern /* Subroutine */ int dgelqf_(int *, int *, double *, int *, double + *, double *, int *, int *), dlascl_(char *, int *, int *, double * + , double *, int *, int *, double *, int *, int *), dgeqrf_(int *, + int *, double *, int *, double *, double *, int *, int *), + dlacpy_(char *, int *, int *, double *, int *, double *, int *), + dlaset_(char *, int *, int *, double *, double *, double *, int *) + , xerbla_(char *, int *), dorgbr_(char *, int *, int *, int *, + double *, int *, double *, double *, int *, int *); + double bignum; + extern /* Subroutine */ int dormbr_(char *, char *, char *, int *, int *, + int *, double *, int *, double *, double *, int *, double *, int * + , int *), dorglq_(int *, int *, int *, double *, int *, double *, + double *, int *, int *), dorgqr_(int *, int *, int *, double *, + int *, double *, double *, int *, int *); + int ldwrkl, ldwrkr, minwrk, ldwrku, maxwrk, ldwkvt; + double smlnum; + int wntqas, lquery; + int lwork_dgebrd_mm__, lwork_dgebrd_mn__, lwork_dgebrd_nn__, + lwork_dgelqf_mn__, lwork_dgeqrf_mn__; + + // + // -- LAPACK driver routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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 allocated 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; + bdspac = 0; + mnthr = (int) (minmn * 11. / 6.); + if (*m >= *n && minmn > 0) { + // + // Compute space needed for DBDSDC + // + if (wntqn) { + // dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) + // keep 7*N for backwards compatibility. + bdspac = *n * 7; + } else { + bdspac = *n * 3 * *n + (*n << 2); + } + // + // Compute space preferred for each routine + dgebrd_(m, n, dum, m, dum, dum, dum, dum, dum, &c_n1, &ierr); + lwork_dgebrd_mn__ = (int) dum[0]; + dgebrd_(n, n, dum, n, dum, dum, dum, dum, dum, &c_n1, &ierr); + lwork_dgebrd_nn__ = (int) dum[0]; + dgeqrf_(m, n, dum, m, dum, dum, &c_n1, &ierr); + lwork_dgeqrf_mn__ = (int) dum[0]; + dorgbr_("Q", n, n, n, dum, n, dum, dum, &c_n1, &ierr); + lwork_dorgbr_q_nn__ = (int) dum[0]; + dorgqr_(m, m, n, dum, m, dum, dum, &c_n1, &ierr); + lwork_dorgqr_mm__ = (int) dum[0]; + dorgqr_(m, n, n, dum, m, dum, dum, &c_n1, &ierr); + lwork_dorgqr_mn__ = (int) dum[0]; + dormbr_("P", "R", "T", n, n, n, dum, n, dum, dum, n, dum, &c_n1, & + ierr); + lwork_dormbr_prt_nn__ = (int) dum[0]; + dormbr_("Q", "L", "N", n, n, n, dum, n, dum, dum, n, dum, &c_n1, & + ierr); + lwork_dormbr_qln_nn__ = (int) dum[0]; + dormbr_("Q", "L", "N", m, n, n, dum, m, dum, dum, m, dum, &c_n1, & + ierr); + lwork_dormbr_qln_mn__ = (int) dum[0]; + dormbr_("Q", "L", "N", m, m, n, dum, m, dum, dum, m, dum, &c_n1, & + ierr); + lwork_dormbr_qln_mm__ = (int) dum[0]; + if (*m >= mnthr) { + if (wntqn) { + // + // Path 1 (M >> N, JOBZ='N') + // + wrkbl = *n + lwork_dgeqrf_mn__; + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dgebrd_nn__; + 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 >> N, JOBZ='O') + // + wrkbl = *n + lwork_dgeqrf_mn__; + // Computing MAX + i__1 = wrkbl, i__2 = *n + lwork_dorgqr_mn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dgebrd_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + bdspac; + wrkbl = max(i__1,i__2); + maxwrk = wrkbl + (*n << 1) * *n; + minwrk = bdspac + (*n << 1) * *n + *n * 3; + } else if (wntqs) { + // + // Path 3 (M >> N, JOBZ='S') + // + wrkbl = *n + lwork_dgeqrf_mn__; + // Computing MAX + i__1 = wrkbl, i__2 = *n + lwork_dorgqr_mn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dgebrd_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + bdspac; + wrkbl = max(i__1,i__2); + maxwrk = wrkbl + *n * *n; + minwrk = bdspac + *n * *n + *n * 3; + } else if (wntqa) { + // + // Path 4 (M >> N, JOBZ='A') + // + wrkbl = *n + lwork_dgeqrf_mn__; + // Computing MAX + i__1 = wrkbl, i__2 = *n + lwork_dorgqr_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dgebrd_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + bdspac; + wrkbl = max(i__1,i__2); + maxwrk = wrkbl + *n * *n; + // Computing MAX + i__1 = *n * 3 + bdspac, i__2 = *n + *m; + minwrk = *n * *n + max(i__1,i__2); + } + } else { + // + // Path 5 (M >= N, but not much larger) + // + wrkbl = *n * 3 + lwork_dgebrd_mn__; + if (wntqn) { + // Path 5n (M >= N, jobz='N') + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + bdspac; + maxwrk = max(i__1,i__2); + minwrk = *n * 3 + max(*m,bdspac); + } else if (wntqo) { + // Path 5o (M >= N, jobz='O') + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_mn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + bdspac; + 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) { + // Path 5s (M >= N, jobz='S') + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_mn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + bdspac; + maxwrk = max(i__1,i__2); + minwrk = *n * 3 + max(*m,bdspac); + } else if (wntqa) { + // Path 5a (M >= N, jobz='A') + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *n * 3 + bdspac; + maxwrk = max(i__1,i__2); + minwrk = *n * 3 + max(*m,bdspac); + } + } + } else if (minmn > 0) { + // + // Compute space needed for DBDSDC + // + if (wntqn) { + // dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) + // keep 7*N for backwards compatibility. + bdspac = *m * 7; + } else { + bdspac = *m * 3 * *m + (*m << 2); + } + // + // Compute space preferred for each routine + dgebrd_(m, n, dum, m, dum, dum, dum, dum, dum, &c_n1, &ierr); + lwork_dgebrd_mn__ = (int) dum[0]; + dgebrd_(m, m, &a[a_offset], m, &s[1], dum, dum, dum, dum, &c_n1, & + ierr); + lwork_dgebrd_mm__ = (int) dum[0]; + dgelqf_(m, n, &a[a_offset], m, dum, dum, &c_n1, &ierr); + lwork_dgelqf_mn__ = (int) dum[0]; + dorglq_(n, n, m, dum, n, dum, dum, &c_n1, &ierr); + lwork_dorglq_nn__ = (int) dum[0]; + dorglq_(m, n, m, &a[a_offset], m, dum, dum, &c_n1, &ierr); + lwork_dorglq_mn__ = (int) dum[0]; + dorgbr_("P", m, m, m, &a[a_offset], n, dum, dum, &c_n1, &ierr); + lwork_dorgbr_p_mm__ = (int) dum[0]; + dormbr_("P", "R", "T", m, m, m, dum, m, dum, dum, m, dum, &c_n1, & + ierr); + lwork_dormbr_prt_mm__ = (int) dum[0]; + dormbr_("P", "R", "T", m, n, m, dum, m, dum, dum, m, dum, &c_n1, & + ierr); + lwork_dormbr_prt_mn__ = (int) dum[0]; + dormbr_("P", "R", "T", n, n, m, dum, n, dum, dum, n, dum, &c_n1, & + ierr); + lwork_dormbr_prt_nn__ = (int) dum[0]; + dormbr_("Q", "L", "N", m, m, m, dum, m, dum, dum, m, dum, &c_n1, & + ierr); + lwork_dormbr_qln_mm__ = (int) dum[0]; + if (*n >= mnthr) { + if (wntqn) { + // + // Path 1t (N >> M, JOBZ='N') + // + wrkbl = *m + lwork_dgelqf_mn__; + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dgebrd_mm__; + 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 >> M, JOBZ='O') + // + wrkbl = *m + lwork_dgelqf_mn__; + // Computing MAX + i__1 = wrkbl, i__2 = *m + lwork_dorglq_mn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dgebrd_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + bdspac; + wrkbl = max(i__1,i__2); + maxwrk = wrkbl + (*m << 1) * *m; + minwrk = bdspac + (*m << 1) * *m + *m * 3; + } else if (wntqs) { + // + // Path 3t (N >> M, JOBZ='S') + // + wrkbl = *m + lwork_dgelqf_mn__; + // Computing MAX + i__1 = wrkbl, i__2 = *m + lwork_dorglq_mn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dgebrd_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + bdspac; + wrkbl = max(i__1,i__2); + maxwrk = wrkbl + *m * *m; + minwrk = bdspac + *m * *m + *m * 3; + } else if (wntqa) { + // + // Path 4t (N >> M, JOBZ='A') + // + wrkbl = *m + lwork_dgelqf_mn__; + // Computing MAX + i__1 = wrkbl, i__2 = *m + lwork_dorglq_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dgebrd_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + bdspac; + wrkbl = max(i__1,i__2); + maxwrk = wrkbl + *m * *m; + // Computing MAX + i__1 = *m * 3 + bdspac, i__2 = *m + *n; + minwrk = *m * *m + max(i__1,i__2); + } + } else { + // + // Path 5t (N > M, but not much larger) + // + wrkbl = *m * 3 + lwork_dgebrd_mn__; + if (wntqn) { + // Path 5tn (N > M, jobz='N') + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + bdspac; + maxwrk = max(i__1,i__2); + minwrk = *m * 3 + max(*n,bdspac); + } else if (wntqo) { + // Path 5to (N > M, jobz='O') + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + bdspac; + 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) { + // Path 5ts (N > M, jobz='S') + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + bdspac; + maxwrk = max(i__1,i__2); + minwrk = *m * 3 + max(*n,bdspac); + } else if (wntqa) { + // Path 5ta (N > M, jobz='A') + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_nn__; + wrkbl = max(i__1,i__2); + // Computing MAX + i__1 = wrkbl, i__2 = *m * 3 + bdspac; + maxwrk = max(i__1,i__2); + minwrk = *m * 3 + max(*n,bdspac); + } + } + } + maxwrk = max(maxwrk,minwrk); + work[1] = (double) 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 >> N, JOBZ='N') + // No singular vectors to be computed + // + itau = 1; + nwork = itau + *n; + // + // Compute A=Q*R + // Workspace: need N [tau] + N [work] + // Workspace: prefer N [tau] + N*NB [work] + // + 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_b63, &c_b63, &a[a_dim1 + 2], + lda); + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + // + // Bidiagonalize R in A + // Workspace: need 3*N [e, tauq, taup] + N [work] + // Workspace: prefer 3*N [e, tauq, taup] + 2*N*NB [work] + // + 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 [e] + 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 >> 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 [R] + N [tau] + N [work] + // Workspace: prefer N*N [R] + N [tau] + N*NB [work] + // + 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_b63, &c_b63, &work[ir + 1], & + ldwrkr); + // + // Generate Q in A + // Workspace: need N*N [R] + N [tau] + N [work] + // Workspace: prefer N*N [R] + N [tau] + N*NB [work] + // + 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 WORK(IR) + // Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] + // Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] + // + 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 [R] + 3*N [e, tauq, taup] + N*N [U] + 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 [R] + 3*N [e, tauq, taup] + N*N [U] + N [work] + // Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N*NB [work] + // + 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 N*N [R] + 3*N [e, tauq, taup] + N*N [U] + // Workspace: prefer M*N [R] + 3*N [e, tauq, taup] + N*N [U] + // + 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_b84, &a[i__ + a_dim1], + lda, &work[iu], n, &c_b63, &work[ir], &ldwrkr); + dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + + a_dim1], lda); +// L10: + } + } else if (wntqs) { + // + // Path 3 (M >> 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 [R] + N [tau] + N [work] + // Workspace: prefer N*N [R] + N [tau] + N*NB [work] + // + 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_b63, &c_b63, &work[ir + 1], & + ldwrkr); + // + // Generate Q in A + // Workspace: need N*N [R] + N [tau] + N [work] + // Workspace: prefer N*N [R] + N [tau] + N*NB [work] + // + 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 [R] + 3*N [e, tauq, taup] + N [work] + // Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] + // + 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*N [R] + 3*N [e, tauq, taup] + 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 [R] + 3*N [e, tauq, taup] + N [work] + // Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*NB [work] + // + 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 [R] + // + dlacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr); + dgemm_("N", "N", m, n, n, &c_b84, &a[a_offset], lda, &work[ir] + , &ldwrkr, &c_b63, &u[u_offset], ldu); + } else if (wntqa) { + // + // Path 4 (M >> 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 [U] + N [tau] + N [work] + // Workspace: prefer N*N [U] + N [tau] + N*NB [work] + // + 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 [U] + N [tau] + M [work] + // Workspace: prefer N*N [U] + N [tau] + M*NB [work] + 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_b63, &c_b63, &a[a_dim1 + 2], + lda); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + // + // Bidiagonalize R in A + // Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] + // Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + 2*N*NB [work] + // + 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 [U] + 3*N [e, tauq, taup] + 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 [U] + 3*N [e, tauq, taup] + N [work] + // Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + N*NB [work] + // + 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 [U] + // + dgemm_("N", "N", m, n, n, &c_b84, &u[u_offset], ldu, &work[iu] + , &ldwrku, &c_b63, &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 >= 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 [e, tauq, taup] + M [work] + // Workspace: prefer 3*N [e, tauq, taup] + (M+N)*NB [work] + // + 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) { + // + // Path 5n (M >= N, JOBZ='N') + // Perform bidiagonal SVD, only computing singular values + // Workspace: need 3*N [e, tauq, taup] + 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 5o (M >= N, JOBZ='O') + 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_b63, &c_b63, &work[iu], &ldwrku); + // IR is unused; silence compile warnings + ir = -1; + } 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 3*N [e, tauq, taup] + N*N [U] + 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 3*N [e, tauq, taup] + N*N [U] + N [work] + // Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] + // + 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) { + // + // Path 5o-fast + // Overwrite WORK(IU) by left singular vectors of A + // Workspace: need 3*N [e, tauq, taup] + M*N [U] + N [work] + // Workspace: prefer 3*N [e, tauq, taup] + M*N [U] + N*NB [work] + // + 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 { + // + // Path 5o-slow + // Generate Q in A + // Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] + // Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] + // + 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 3*N [e, tauq, taup] + N*N [U] + NB*N [R] + // Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + M*N [R] + // + 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_b84, &a[i__ + + a_dim1], lda, &work[iu], &ldwrku, &c_b63, & + work[ir], &ldwrkr); + dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + + a_dim1], lda); +// L20: + } + } + } else if (wntqs) { + // + // Path 5s (M >= N, JOBZ='S') + // Perform bidiagonal SVD, computing left singular vectors + // of bidiagonal matrix in U and computing right singular + // vectors of bidiagonal matrix in VT + // Workspace: need 3*N [e, tauq, taup] + BDSPAC + // + dlaset_("F", m, n, &c_b63, &c_b63, &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 [e, tauq, taup] + N [work] + // Workspace: prefer 3*N [e, tauq, taup] + N*NB [work] + // + 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) { + // + // Path 5a (M >= N, JOBZ='A') + // Perform bidiagonal SVD, computing left singular vectors + // of bidiagonal matrix in U and computing right singular + // vectors of bidiagonal matrix in VT + // Workspace: need 3*N [e, tauq, taup] + BDSPAC + // + dlaset_("F", m, m, &c_b63, &c_b63, &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_b63, &c_b84, &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 3*N [e, tauq, taup] + M [work] + // Workspace: prefer 3*N [e, tauq, taup] + M*NB [work] + // + 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 >> M, JOBZ='N') + // No singular vectors to be computed + // + itau = 1; + nwork = itau + *m; + // + // Compute A=L*Q + // Workspace: need M [tau] + M [work] + // Workspace: prefer M [tau] + M*NB [work] + // + 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_b63, &c_b63, &a[(a_dim1 << 1) + + 1], lda); + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + // + // Bidiagonalize L in A + // Workspace: need 3*M [e, tauq, taup] + M [work] + // Workspace: prefer 3*M [e, tauq, taup] + 2*M*NB [work] + // + 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 [e] + 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 >> M, JOBZ='O') + // M right singular vectors to be overwritten on A and + // M left singular vectors to be computed in U + // + ivt = 1; + // + // WORK(IVT) is M by M + // WORK(IL) is M by M; it is later resized to M by chunk for gemm + // + il = ivt + *m * *m; + if (*lwork >= *m * *n + *m * *m + *m * 3 + bdspac) { + 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 [VT] + M*M [L] + M [tau] + M [work] + // Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] + // + 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_b63, &c_b63, &work[il + ldwrkl], + &ldwrkl); + // + // Generate Q in A + // Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] + // Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] + // + 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 [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] + // Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] + // + 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 [VT] + M*M [L] + 3*M [e, tauq, taup] + 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 M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] + // Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M*NB [work] + // + 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 M*M [VT] + M*M [L] + // Workspace: prefer M*M [VT] + M*N [L] + // At this point, L is resized as M by chunk. + // + 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_b84, &work[ivt], m, &a[ + i__ * a_dim1 + 1], lda, &c_b63, &work[il], & + ldwrkl); + dlacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1 + + 1], lda); +// L30: + } + } else if (wntqs) { + // + // Path 3t (N >> 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 [L] + M [tau] + M [work] + // Workspace: prefer M*M [L] + M [tau] + M*NB [work] + // + 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_b63, &c_b63, &work[il + ldwrkl], + &ldwrkl); + // + // Generate Q in A + // Workspace: need M*M [L] + M [tau] + M [work] + // Workspace: prefer M*M [L] + M [tau] + M*NB [work] + // + 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). + // Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] + // Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] + // + 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*M [L] + 3*M [e, tauq, taup] + 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 [L] + 3*M [e, tauq, taup] + M [work] + // Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + M*NB [work] + // + 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 [L] + // + dlacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl); + dgemm_("N", "N", m, n, m, &c_b84, &work[il], &ldwrkl, &a[ + a_offset], lda, &c_b63, &vt[vt_offset], ldvt); + } else if (wntqa) { + // + // Path 4t (N >> 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 [VT] + M [tau] + M [work] + // Workspace: prefer M*M [VT] + M [tau] + M*NB [work] + // + 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 [VT] + M [tau] + N [work] + // Workspace: prefer M*M [VT] + M [tau] + N*NB [work] + // + 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_b63, &c_b63, &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 [VT] + 3*M [e, tauq, taup] + M [work] + // Workspace: prefer M*M [VT] + 3*M [e, tauq, taup] + 2*M*NB [work] + // + 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 [VT] + 3*M [e, tauq, taup] + 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 [VT] + 3*M [e, tauq, taup]+ M [work] + // Workspace: prefer M*M [VT] + 3*M [e, tauq, taup]+ M*NB [work] + // + 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 [VT] + // + dgemm_("N", "N", m, n, m, &c_b84, &work[ivt], &ldwkvt, &vt[ + vt_offset], ldvt, &c_b63, &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 > 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 [e, tauq, taup] + N [work] + // Workspace: prefer 3*M [e, tauq, taup] + (M+N)*NB [work] + // + 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) { + // + // Path 5tn (N > M, JOBZ='N') + // Perform bidiagonal SVD, only computing singular values + // Workspace: need 3*M [e, tauq, taup] + 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) { + // Path 5to (N > M, JOBZ='O') + ldwkvt = *m; + ivt = nwork; + if (*lwork >= *m * *n + *m * 3 + bdspac) { + // + // WORK( IVT ) is M by N + // + dlaset_("F", m, n, &c_b63, &c_b63, &work[ivt], &ldwkvt); + nwork = ivt + ldwkvt * *n; + // IL is unused; silence compile warnings + il = -1; + } 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 3*M [e, tauq, taup] + M*M [VT] + 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 3*M [e, tauq, taup] + M*M [VT] + M [work] + // Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] + // + 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) { + // + // Path 5to-fast + // Overwrite WORK(IVT) by left singular vectors of A + // Workspace: need 3*M [e, tauq, taup] + M*N [VT] + M [work] + // Workspace: prefer 3*M [e, tauq, taup] + M*N [VT] + M*NB [work] + // + 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 { + // + // Path 5to-slow + // Generate P**T in A + // Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] + // Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] + // + 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 3*M [e, tauq, taup] + M*M [VT] + M*NB [L] + // Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*N [L] + // + 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_b84, &work[ivt], & + ldwkvt, &a[i__ * a_dim1 + 1], lda, &c_b63, & + work[il], m); + dlacpy_("F", m, &blk, &work[il], m, &a[i__ * a_dim1 + + 1], lda); +// L40: + } + } + } else if (wntqs) { + // + // Path 5ts (N > M, JOBZ='S') + // Perform bidiagonal SVD, computing left singular vectors + // of bidiagonal matrix in U and computing right singular + // vectors of bidiagonal matrix in VT + // Workspace: need 3*M [e, tauq, taup] + BDSPAC + // + dlaset_("F", m, n, &c_b63, &c_b63, &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 [e, tauq, taup] + M [work] + // Workspace: prefer 3*M [e, tauq, taup] + M*NB [work] + // + 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) { + // + // Path 5ta (N > M, JOBZ='A') + // Perform bidiagonal SVD, computing left singular vectors + // of bidiagonal matrix in U and computing right singular + // vectors of bidiagonal matrix in VT + // Workspace: need 3*M [e, tauq, taup] + BDSPAC + // + dlaset_("F", n, n, &c_b63, &c_b63, &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_b63, &c_b84, &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 3*M [e, tauq, taup] + N [work] + // Workspace: prefer 3*M [e, tauq, taup] + N*NB [work] + // + 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] = (double) maxwrk; + return 0; + // + // End of DGESDD + // +} // dgesdd_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLABRD + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, +// LDY ) +// +// .. Scalar Arguments .. +// INTEGER LDA, LDX, LDY, M, N, NB +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), +// $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T * 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 +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows in the matrix A. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns in the matrix A. +//> \endverbatim +//> +//> \param[in] NB +//> \verbatim +//> NB is INTEGER +//> The number of leading rows and columns of A to be reduced. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension (NB) +//> The diagonal elements of the first NB rows and columns of +//> the reduced matrix. D(i) = A(i,i). +//> \endverbatim +//> +//> \param[out] E +//> \verbatim +//> E is DOUBLE PRECISION array, dimension (NB) +//> The off-diagonal elements of the first NB rows and columns of +//> the reduced matrix. +//> \endverbatim +//> +//> \param[out] TAUQ +//> \verbatim +//> TAUQ is DOUBLE PRECISION array, dimension (NB) +//> The scalar factors of the elementary reflectors which +//> represent the orthogonal matrix Q. See Further Details. +//> \endverbatim +//> +//> \param[out] TAUP +//> \verbatim +//> TAUP is DOUBLE PRECISION array, dimension (NB) +//> The scalar factors of the elementary reflectors which +//> represent the orthogonal matrix P. See Further Details. +//> \endverbatim +//> +//> \param[out] X +//> \verbatim +//> X is DOUBLE PRECISION array, dimension (LDX,NB) +//> The m-by-nb matrix X required to update the unreduced part +//> of A. +//> \endverbatim +//> +//> \param[in] LDX +//> \verbatim +//> LDX is INTEGER +//> The leading dimension of the array X. LDX >= max(1,M). +//> \endverbatim +//> +//> \param[out] Y +//> \verbatim +//> Y is DOUBLE PRECISION array, dimension (LDY,NB) +//> The n-by-nb matrix Y required to update the unreduced part +//> of A. +//> \endverbatim +//> +//> \param[in] LDY +//> \verbatim +//> LDY is INTEGER +//> The leading dimension of the array Y. LDY >= max(1,N). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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**T and G(i) = I - taup * u * u**T +//> +//> 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**T 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**T - X*U**T. +//> +//> 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). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlabrd_(int *m, int *n, int *nb, double *a, int *lda, + double *d__, double *e, double *tauq, double *taup, double *x, int * + ldx, double *y, int *ldy) +{ + // Table of constant values + double c_b4 = -1.; + double c_b5 = 1.; + int c__1 = 1; + double c_b16 = 0.; + + // System generated locals + int a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, + i__3; + + // Local variables + int i__; + extern /* Subroutine */ int dscal_(int *, double *, double *, int *), + dgemv_(char *, int *, int *, double *, double *, int *, double *, + int *, double *, double *, int *), dlarfg_(int *, double *, + double *, int *, double *); + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAED6 used by sstedc. Computes one Newton step in solution of the secular equation. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAED6 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) +// +// .. Scalar Arguments .. +// LOGICAL ORGATI +// INTEGER INFO, KNITER +// DOUBLE PRECISION FINIT, RHO, TAU +// .. +// .. Array Arguments .. +// DOUBLE PRECISION D( 3 ), Z( 3 ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] KNITER +//> \verbatim +//> KNITER is INTEGER +//> Refer to DLAED4 for its significance. +//> \endverbatim +//> +//> \param[in] ORGATI +//> \verbatim +//> ORGATI is 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. +//> \endverbatim +//> +//> \param[in] RHO +//> \verbatim +//> RHO is DOUBLE PRECISION +//> Refer to the equation f(x) above. +//> \endverbatim +//> +//> \param[in] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension (3) +//> D satisfies d(1) < d(2) < d(3). +//> \endverbatim +//> +//> \param[in] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (3) +//> Each of the elements in z must be positive. +//> \endverbatim +//> +//> \param[in] FINIT +//> \verbatim +//> FINIT is 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). +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION +//> The root of the equation f(x). +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> > 0: if INFO = 1, failure to converge +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup auxOTHERcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +//> \par Contributors: +// ================== +//> +//> Ren-Cang Li, Computer Science Division, University of California +//> at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlaed6_(int *kniter, int *orgati, double *rho, double * + d__, double *z__, double *finit, double *tau, int *info) +{ + // System generated locals + int i__1; + double d__1, d__2, d__3, d__4; + + // Local variables + double a, b, c__, f; + int i__; + double fc, df, ddf, lbd, eta, ubd, eps, base; + int iter; + double temp, temp1, temp2, temp3, temp4; + int scale; + int niter; + double small1, small2, sminv1, sminv2; + extern double dlamch_(char *); + double dscale[3], sclfac, zscale[3], erretm, sclinv; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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 = (int) (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__) { + if (dscale[i__ - 1] - *tau != 0.) { + 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; + } else { + goto L60; + } +// L40: + } + f = *finit + *tau * fc; + erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df; + if (abs(f) <= eps * 4. * erretm || ubd - lbd <= eps * 4. * abs(*tau)) + { + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAMRG + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) +// +// .. Scalar Arguments .. +// INTEGER DTRD1, DTRD2, N1, N2 +// .. +// .. Array Arguments .. +// INTEGER INDEX( * ) +// DOUBLE PRECISION A( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N1 +//> \verbatim +//> N1 is INTEGER +//> \endverbatim +//> +//> \param[in] N2 +//> \verbatim +//> N2 is INTEGER +//> These arguments contain the respective lengths of the two +//> sorted lists to be merged. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] DTRD1 +//> \verbatim +//> DTRD1 is INTEGER +//> \endverbatim +//> +//> \param[in] DTRD2 +//> \verbatim +//> DTRD2 is 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. +//> \endverbatim +//> +//> \param[out] INDEX +//> \verbatim +//> INDEX is 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. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup auxOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dlamrg_(int *n1, int *n2, double *a, int *dtrd1, int * + dtrd2, int *index) +{ + // System generated locals + int i__1; + + // Local variables + int i__, ind1, ind2, n1sv, n2sv; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLANST + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) +// +// .. Scalar Arguments .. +// CHARACTER NORM +// INTEGER N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION D( * ), E( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +//> \return DLANST +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] NORM +//> \verbatim +//> NORM is CHARACTER*1 +//> Specifies the value to be returned in DLANST as described +//> above. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the matrix A. N >= 0. When N = 0, DLANST is +//> set to zero. +//> \endverbatim +//> +//> \param[in] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension (N) +//> The diagonal elements of A. +//> \endverbatim +//> +//> \param[in] E +//> \verbatim +//> E is DOUBLE PRECISION array, dimension (N-1) +//> The (n-1) sub-diagonal or super-diagonal elements of A. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +double dlanst_(char *norm, int *n, double *d__, double *e) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int i__1; + double ret_val, d__1, d__2, d__3; + + // Local variables + int i__; + double sum, scale; + extern int lsame_(char *, char *); + double anorm; + extern int disnan_(double *); + extern /* Subroutine */ int dlassq_(int *, double *, int *, double *, + double *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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__) { + sum = (d__1 = d__[i__], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + sum = (d__1 = e[i__], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } +// L10: + } + } else if (lsame_(norm, "O") || *(unsigned char *)norm == '1' || lsame_( + norm, "I")) { + // + // Find norm1(A). + // + if (*n == 1) { + anorm = abs(d__[1]); + } else { + anorm = abs(d__[1]) + abs(e[1]); + sum = (d__1 = e[*n - 1], abs(d__1)) + (d__2 = d__[*n], abs(d__2)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2) + ) + (d__3 = e[i__ - 1], abs(d__3)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } +// 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAS2 computes singular values of a 2-by-2 triangular matrix. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAS2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION F, G, H, SSMAX, SSMIN +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] F +//> \verbatim +//> F is DOUBLE PRECISION +//> The (1,1) element of the 2-by-2 matrix. +//> \endverbatim +//> +//> \param[in] G +//> \verbatim +//> G is DOUBLE PRECISION +//> The (1,2) element of the 2-by-2 matrix. +//> \endverbatim +//> +//> \param[in] H +//> \verbatim +//> H is DOUBLE PRECISION +//> The (2,2) element of the 2-by-2 matrix. +//> \endverbatim +//> +//> \param[out] SSMIN +//> \verbatim +//> SSMIN is DOUBLE PRECISION +//> The smaller singular value. +//> \endverbatim +//> +//> \param[out] SSMAX +//> \verbatim +//> SSMAX is DOUBLE PRECISION +//> The larger singular value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlas2_(double *f, double *g, double *h__, double *ssmin, + double *ssmax) +{ + // System generated locals + double d__1, d__2; + + // Local variables + double c__, fa, ga, ha, as, at, au, fhmn, fhmx; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // + // ==================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD0 computes the singular values of a real upper bidiagonal n-by-m matrix B with diagonal d and off-diagonal e. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD0 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, +// WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE +// .. +// .. Array Arguments .. +// INTEGER IWORK( * ) +// DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), +// $ WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> On entry, the row dimension of the upper bidiagonal matrix. +//> This is also the dimension of the main diagonal array D. +//> \endverbatim +//> +//> \param[in] SQRE +//> \verbatim +//> SQRE is 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; +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[in,out] E +//> \verbatim +//> E is DOUBLE PRECISION array, dimension (M-1) +//> Contains the subdiagonal entries of the bidiagonal matrix. +//> On exit, E has been destroyed. +//> \endverbatim +//> +//> \param[out] U +//> \verbatim +//> U is DOUBLE PRECISION array, dimension (LDU, N) +//> On exit, U contains the left singular vectors. +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER +//> On entry, leading dimension of U. +//> \endverbatim +//> +//> \param[out] VT +//> \verbatim +//> VT is DOUBLE PRECISION array, dimension (LDVT, M) +//> On exit, VT**T contains the right singular vectors. +//> \endverbatim +//> +//> \param[in] LDVT +//> \verbatim +//> LDVT is INTEGER +//> On entry, leading dimension of VT. +//> \endverbatim +//> +//> \param[in] SMLSIZ +//> \verbatim +//> SMLSIZ is INTEGER +//> On entry, maximum size of the subproblems at the +//> bottom of the computation tree. +//> \endverbatim +//> +//> \param[out] IWORK +//> \verbatim +//> IWORK is INTEGER array, dimension (8*N) +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (3*M**2+2*M) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: if INFO = 1, a singular value did not converge +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd0_(int *n, int *sqre, double *d__, double *e, + double *u, int *ldu, double *vt, int *ldvt, int *smlsiz, int *iwork, + double *work, int *info) +{ + // Table of constant values + int c__0 = 0; + int c__2 = 2; + + // System generated locals + int u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + + // Local variables + int i__, j, m, i1, ic, lf, nd, ll, nl, nr, im1, ncc, nlf, nrf, iwk, lvl, + ndb1, nlp1, nrp1; + double beta; + int idxq, nlvl; + double alpha; + int inode, ndiml, idxqc, ndimr, itemp, sqrei; + extern /* Subroutine */ int dlasd1_(int *, int *, int *, double *, double + *, double *, double *, int *, double *, int *, int *, int *, + double *, int *), dlasdq_(char *, int *, int *, int *, int *, int + *, double *, double *, double *, int *, double *, int *, double *, + int *, double *, int *), dlasdt_(int *, int *, int *, int *, int + *, int *, int *), xerbla_(char *, int *); + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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); + // + // Report the possible convergence failure. + // + if (*info != 0) { + return 0; + } +// L40: + } +// L50: + } + return 0; + // + // End of DLASD0 + // +} // dlasd0_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD1 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, +// IDXQ, IWORK, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, LDU, LDVT, NL, NR, SQRE +// DOUBLE PRECISION ALPHA, BETA +// .. +// .. Array Arguments .. +// INTEGER IDXQ( * ), IWORK( * ) +// DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T a Z2**T b ) * VT(in) +//> ( 0 0 D2(in) 0 ) +//> +//> = U(out) * ( D(out) 0) * VT(out) +//> +//> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, 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 occurrence 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] NL +//> \verbatim +//> NL is INTEGER +//> The row dimension of the upper block. NL >= 1. +//> \endverbatim +//> +//> \param[in] NR +//> \verbatim +//> NR is INTEGER +//> The row dimension of the lower block. NR >= 1. +//> \endverbatim +//> +//> \param[in] SQRE +//> \verbatim +//> SQRE is 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. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[in,out] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION +//> Contains the diagonal element associated with the added row. +//> \endverbatim +//> +//> \param[in,out] BETA +//> \verbatim +//> BETA is DOUBLE PRECISION +//> Contains the off-diagonal element associated with the added +//> row. +//> \endverbatim +//> +//> \param[in,out] U +//> \verbatim +//> U is 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. +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER +//> The leading dimension of the array U. LDU >= max( 1, N ). +//> \endverbatim +//> +//> \param[in,out] VT +//> \verbatim +//> VT is DOUBLE PRECISION array, dimension(LDVT,M) +//> where M = N + SQRE. +//> On entry VT(1:NL+1, 1:NL+1)**T contains the right singular +//> vectors of the upper block; VT(NL+2:M, NL+2:M)**T contains +//> the right singular vectors of the lower block. On exit +//> VT**T contains the right singular vectors of the +//> bidiagonal matrix. +//> \endverbatim +//> +//> \param[in] LDVT +//> \verbatim +//> LDVT is INTEGER +//> The leading dimension of the array VT. LDVT >= max( 1, M ). +//> \endverbatim +//> +//> \param[in,out] IDXQ +//> \verbatim +//> IDXQ is 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. +//> \endverbatim +//> +//> \param[out] IWORK +//> \verbatim +//> IWORK is INTEGER array, dimension( 4 * N ) +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: if INFO = 1, a singular value did not converge +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd1_(int *nl, int *nr, int *sqre, double *d__, double + *alpha, double *beta, double *u, int *ldu, double *vt, int *ldvt, int + *idxq, int *iwork, double *work, int *info) +{ + // Table of constant values + int c__0 = 0; + double c_b7 = 1.; + int c__1 = 1; + int c_n1 = -1; + + // System generated locals + int u_dim1, u_offset, vt_dim1, vt_offset, i__1; + double d__1, d__2; + + // Local variables + int i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc, idxp, + ldvt2; + extern /* Subroutine */ int dlasd2_(int *, int *, int *, int *, double *, + double *, double *, double *, double *, int *, double *, int *, + double *, double *, int *, double *, int *, int *, int *, int *, + int *, int *, int *), dlasd3_(int *, int *, int *, int *, double * + , double *, int *, double *, double *, int *, double *, int *, + double *, int *, double *, int *, int *, int *, double *, int *), + dlascl_(char *, int *, int *, double *, double *, int *, int *, + double *, int *, int *), dlamrg_(int *, int *, double *, int *, + int *, int *); + int isigma; + extern /* Subroutine */ int xerbla_(char *, int *); + double orgnrm; + int coltyp; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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); + // + // Report the convergence failure. + // + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, +// LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, +// IDXC, IDXQ, COLTYP, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE +// DOUBLE PRECISION ALPHA, BETA +// .. +// .. Array Arguments .. +// INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), +// $ IDXQ( * ) +// DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ), +// $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), +// $ Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] NL +//> \verbatim +//> NL is INTEGER +//> The row dimension of the upper block. NL >= 1. +//> \endverbatim +//> +//> \param[in] NR +//> \verbatim +//> NR is INTEGER +//> The row dimension of the lower block. NR >= 1. +//> \endverbatim +//> +//> \param[in] SQRE +//> \verbatim +//> SQRE is 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. +//> \endverbatim +//> +//> \param[out] K +//> \verbatim +//> K is INTEGER +//> Contains the dimension of the non-deflated matrix, +//> This is the order of the related secular equation. 1 <= K <=N. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension(N) +//> On exit Z contains the updating row vector in the secular +//> equation. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION +//> Contains the diagonal element associated with the added row. +//> \endverbatim +//> +//> \param[in] BETA +//> \verbatim +//> BETA is DOUBLE PRECISION +//> Contains the off-diagonal element associated with the added +//> row. +//> \endverbatim +//> +//> \param[in,out] U +//> \verbatim +//> U is 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. +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER +//> The leading dimension of the array U. LDU >= N. +//> \endverbatim +//> +//> \param[in,out] VT +//> \verbatim +//> VT is DOUBLE PRECISION array, dimension(LDVT,M) +//> On entry VT**T 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**T 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. +//> \endverbatim +//> +//> \param[in] LDVT +//> \verbatim +//> LDVT is INTEGER +//> The leading dimension of the array VT. LDVT >= M. +//> \endverbatim +//> +//> \param[out] DSIGMA +//> \verbatim +//> DSIGMA is DOUBLE PRECISION array, dimension (N) +//> Contains a copy of the diagonal elements (K-1 singular values +//> and one zero) in the secular equation. +//> \endverbatim +//> +//> \param[out] U2 +//> \verbatim +//> U2 is 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. +//> \endverbatim +//> +//> \param[in] LDU2 +//> \verbatim +//> LDU2 is INTEGER +//> The leading dimension of the array U2. LDU2 >= N. +//> \endverbatim +//> +//> \param[out] VT2 +//> \verbatim +//> VT2 is DOUBLE PRECISION array, dimension(LDVT2,N) +//> VT2**T 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. +//> \endverbatim +//> +//> \param[in] LDVT2 +//> \verbatim +//> LDVT2 is INTEGER +//> The leading dimension of the array VT2. LDVT2 >= M. +//> \endverbatim +//> +//> \param[out] IDXP +//> \verbatim +//> IDXP is 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. +//> \endverbatim +//> +//> \param[out] IDX +//> \verbatim +//> IDX is INTEGER array, dimension(N) +//> This will contain the permutation used to sort the contents of +//> D into ascending order. +//> \endverbatim +//> +//> \param[out] IDXC +//> \verbatim +//> IDXC is 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. +//> \endverbatim +//> +//> \param[in,out] IDXQ +//> \verbatim +//> IDXQ is 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. +//> \endverbatim +//> +//> \param[out] COLTYP +//> \verbatim +//> COLTYP is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd2_(int *nl, int *nr, int *sqre, int *k, double *d__, + double *z__, double *alpha, double *beta, double *u, int *ldu, + double *vt, int *ldvt, double *dsigma, double *u2, int *ldu2, double * + vt2, int *ldvt2, int *idxp, int *idx, int *idxc, int *idxq, int * + coltyp, int *info) +{ + // Table of constant values + int c__1 = 1; + double c_b30 = 0.; + + // System generated locals + int u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, vt2_dim1, + vt2_offset, i__1; + double d__1, d__2; + + // Local variables + double c__; + int i__, j, m, n; + double s; + int k2; + double z1; + int ct, jp; + double eps, tau, tol; + int psm[4], nlp1, nlp2, idxi, idxj; + extern /* Subroutine */ int drot_(int *, double *, int *, double *, int *, + double *, double *); + int ctot[4], idxjp; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + int jprev; + extern double dlapy2_(double *, double *), dlamch_(char *); + extern /* Subroutine */ int dlamrg_(int *, int *, double *, int *, int *, + int *), dlacpy_(char *, int *, int *, double *, int *, double *, + int *), dlaset_(char *, int *, int *, double *, double *, double * + , int *), xerbla_(char *, int *); + double hlftol; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and Z, and then updates the singular vectors by matrix multiplication. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD3 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, +// LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, +// INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, +// $ SQRE +// .. +// .. Array Arguments .. +// INTEGER CTOT( * ), IDXC( * ) +// DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), +// $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), +// $ Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] NL +//> \verbatim +//> NL is INTEGER +//> The row dimension of the upper block. NL >= 1. +//> \endverbatim +//> +//> \param[in] NR +//> \verbatim +//> NR is INTEGER +//> The row dimension of the lower block. NR >= 1. +//> \endverbatim +//> +//> \param[in] SQRE +//> \verbatim +//> SQRE is 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. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The size of the secular equation, 1 =< K = < N. +//> \endverbatim +//> +//> \param[out] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension(K) +//> On exit the square roots of the roots of the secular equation, +//> in ascending order. +//> \endverbatim +//> +//> \param[out] Q +//> \verbatim +//> Q is DOUBLE PRECISION array, dimension (LDQ,K) +//> \endverbatim +//> +//> \param[in] LDQ +//> \verbatim +//> LDQ is INTEGER +//> The leading dimension of the array Q. LDQ >= K. +//> \endverbatim +//> +//> \param[in,out] DSIGMA +//> \verbatim +//> DSIGMA is 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. +//> \endverbatim +//> +//> \param[out] U +//> \verbatim +//> U is DOUBLE PRECISION array, dimension (LDU, N) +//> The last N - K columns of this matrix contain the deflated +//> left singular vectors. +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER +//> The leading dimension of the array U. LDU >= N. +//> \endverbatim +//> +//> \param[in] U2 +//> \verbatim +//> U2 is DOUBLE PRECISION array, dimension (LDU2, N) +//> The first K columns of this matrix contain the non-deflated +//> left singular vectors for the split problem. +//> \endverbatim +//> +//> \param[in] LDU2 +//> \verbatim +//> LDU2 is INTEGER +//> The leading dimension of the array U2. LDU2 >= N. +//> \endverbatim +//> +//> \param[out] VT +//> \verbatim +//> VT is DOUBLE PRECISION array, dimension (LDVT, M) +//> The last M - K columns of VT**T contain the deflated +//> right singular vectors. +//> \endverbatim +//> +//> \param[in] LDVT +//> \verbatim +//> LDVT is INTEGER +//> The leading dimension of the array VT. LDVT >= N. +//> \endverbatim +//> +//> \param[in,out] VT2 +//> \verbatim +//> VT2 is DOUBLE PRECISION array, dimension (LDVT2, N) +//> The first K columns of VT2**T contain the non-deflated +//> right singular vectors for the split problem. +//> \endverbatim +//> +//> \param[in] LDVT2 +//> \verbatim +//> LDVT2 is INTEGER +//> The leading dimension of the array VT2. LDVT2 >= N. +//> \endverbatim +//> +//> \param[in] IDXC +//> \verbatim +//> IDXC is 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. +//> \endverbatim +//> +//> \param[in] CTOT +//> \verbatim +//> CTOT is 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. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension (K) +//> The first K elements of this array contain the components +//> of the deflation-adjusted updating row vector. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: if INFO = 1, a singular value did not converge +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd3_(int *nl, int *nr, int *sqre, int *k, double *d__, + double *q, int *ldq, double *dsigma, double *u, int *ldu, double *u2, + int *ldu2, double *vt, int *ldvt, double *vt2, int *ldvt2, int *idxc, + int *ctot, double *z__, int *info) +{ + // Table of constant values + int c__1 = 1; + int c__0 = 0; + double c_b13 = 1.; + double c_b26 = 0.; + + // System generated locals + int q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, + vt_offset, vt2_dim1, vt2_offset, i__1, i__2; + double d__1, d__2; + + // Local variables + int i__, j, m, n, jc; + double rho; + int nlp1, nlp2, nrp1; + double temp; + extern double dnrm2_(int *, double *, int *); + extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *, + double *, double *, int *, double *, int *, double *, double *, + int *); + int ctemp; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + int ktemp; + extern double dlamc3_(double *, double *); + extern /* Subroutine */ int dlasd4_(int *, int *, double *, double *, + double *, double *, double *, double *, int *), dlascl_(char *, + int *, int *, double *, double *, int *, int *, double *, int *, + int *), dlacpy_(char *, int *, int *, double *, int *, double *, + int *), xerbla_(char *, int *); + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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, report the convergence failure. + // + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by dbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD4 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER I, INFO, N +// DOUBLE PRECISION RHO, SIGMA +// .. +// .. Array Arguments .. +// DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The length of all arrays. +//> \endverbatim +//> +//> \param[in] I +//> \verbatim +//> I is INTEGER +//> The index of the eigenvalue to be computed. 1 <= I <= N. +//> \endverbatim +//> +//> \param[in] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension ( N ) +//> The original eigenvalues. It is assumed that they are in +//> order, 0 <= D(I) < D(J) for I < J. +//> \endverbatim +//> +//> \param[in] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension ( N ) +//> The components of the updating vector. +//> \endverbatim +//> +//> \param[out] DELTA +//> \verbatim +//> DELTA is 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. +//> \endverbatim +//> +//> \param[in] RHO +//> \verbatim +//> RHO is DOUBLE PRECISION +//> The scalar in the symmetric updating formula. +//> \endverbatim +//> +//> \param[out] SIGMA +//> \verbatim +//> SIGMA is DOUBLE PRECISION +//> The computed sigma_I, the I-th updated eigenvalue. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> > 0: if INFO = 1, the updating process failed. +//> \endverbatim +// +//> \par Internal Parameters: +// ========================= +//> +//> \verbatim +//> 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. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ren-Cang Li, Computer Science Division, University of California +//> at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd4_(int *n, int *i__, double *d__, double *z__, + double *delta, double *rho, double *sigma, double *work, int *info) +{ + // System generated locals + int i__1; + double d__1; + + // Local variables + double a, b, c__; + int j; + double w, dd[3]; + int ii; + double dw, zz[3]; + int ip1; + double sq2, eta, phi, eps, tau, psi; + int iim1, iip1; + double tau2, dphi, sglb, dpsi, sgub; + int iter; + double temp, prew, temp1, temp2, dtiim, delsq, dtiip; + int niter; + double dtisq; + int swtch; + double dtnsq; + extern /* Subroutine */ int dlaed6_(int *, int *, double *, double *, + double *, double *, double *, int *), dlasd5_(int *, double *, + double *, double *, double *, double *, double *); + double delsq2, dtnsq1; + int swtch3; + extern double dlamch_(char *); + int orgati; + double erretm, dtipsq, rhoinv; + int geomavg; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + tau2 = 0.; + // + // 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 TAU2 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.) { + tau2 = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau2 = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); + } + // + // It can be proved that + // D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= 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 TAU2 is to approximate + // SIGMA_n^2 - D( N )*D( N ) + // + if (a < 0.) { + tau2 = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau2 = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); + // + // It can be proved that + // D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2 + // + } + // + // The following TAU is to approximate SIGMA_n - D( N ) + // + // TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) + // + *sigma = d__[*n] + tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*n] - tau; + work[j] = d__[j] + d__[*n] + 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] * 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( TAU2 )*( 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; + } + eta /= *sigma + sqrt(eta + *sigma * *sigma); + tau += eta; + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; +// L50: + } + // + // 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 + // + tau2 = work[*n] * delta[*n]; + temp = z__[*n] / tau2; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; + // $ + ABS( TAU2 )*( DPSI+DPHI ) + // + w = rhoinv + phi + psi; + // + // Main loop to update the values of the array DELTA + // + iter = niter + 1; + for (niter = iter; niter <= 400; ++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.; + } + eta /= *sigma + sqrt(eta + *sigma * *sigma); + tau += eta; + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; +// L70: + } + // + // 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 + // + tau2 = work[*n] * delta[*n]; + temp = z__[*n] / tau2; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; + // $ + ABS( TAU2 )*( 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.; + sq2 = sqrt((d__[*i__] * d__[*i__] + d__[ip1] * d__[ip1]) / 2.); + temp = delsq2 / (d__[*i__] + sq2); + 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]); + geomavg = FALSE_; + 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_; + ii = *i__; + sglb = 0.; + sgub = delsq2 / (d__[*i__] + sq2); + a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * delsq; + if (a > 0.) { + tau2 = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } else { + tau2 = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / + (c__ * 2.); + } + // + // TAU2 now is an estimation of SIGMA^2 - D( I )^2. The + // following, however, is the corresponding estimation of + // SIGMA - D( I ). + // + tau = tau2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau2)); + temp = sqrt(eps); + if (d__[*i__] <= temp * d__[ip1] && (d__1 = z__[*i__], abs(d__1)) + <= temp && d__[*i__] > 0.) { + // Computing MIN + d__1 = d__[*i__] * 10.; + tau = min(d__1,sgub); + geomavg = TRUE_; + } + } 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_; + ii = ip1; + sglb = -delsq2 / (d__[ii] + sq2); + sgub = 0.; + a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * delsq; + if (a < 0.) { + tau2 = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( + d__1)))); + } else { + tau2 = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / + (c__ * 2.); + } + // + // TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The + // following, however, is the corresponding estimation of + // SIGMA - D( IP1 ). + // + tau = tau2 / (d__[ip1] + sqrt((d__1 = d__[ip1] * d__[ip1] + tau2, + abs(d__1)))); + } + *sigma = d__[ii] + tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[ii] + tau; + delta[j] = d__[j] - d__[ii] - tau; +// L130: + } + 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( TAU2 )*DW + // + // Test for convergence + // + if (abs(w) <= eps * erretm) { + goto L240; + } + if (w <= 0.) { + sglb = max(sglb,tau); + } else { + sgub = min(sgub,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) { + // + // If INFO is not 0, i.e., DLAED6 failed, switch back + // to 2 pole interpolation. + // + swtch3 = FALSE_; + *info = 0; + 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)))); + } + } + } + // + // 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; + } + eta /= *sigma + sqrt(*sigma * *sigma + eta); + temp = tau + eta; + if (temp > sgub || temp < sglb) { + if (w < 0.) { + eta = (sgub - tau) / 2.; + } else { + eta = (sglb - tau) / 2.; + } + if (geomavg) { + if (w < 0.) { + if (tau > 0.) { + eta = sqrt(sgub * tau) - tau; + } + } else { + if (sglb > 0.) { + eta = sqrt(sglb * tau) - tau; + } + } + } + } + prew = w; + tau += eta; + *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: + } + tau2 = work[ii] * delta[ii]; + temp = z__[ii] / tau2; + 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( TAU2 )*DW + // + 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 <= 400; ++niter) { + // + // Test for convergence + // + if (abs(w) <= eps * erretm) { + // $ .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN + goto L240; + } + if (w <= 0.) { + sglb = max(sglb,tau); + } else { + sgub = min(sgub,tau); + } + // + // 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) { + // + // If INFO is not 0, i.e., DLAED6 failed, switch + // back to two pole interpolation + // + swtch3 = FALSE_; + *info = 0; + 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)))); + } + } + } + // + // 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; + } + eta /= *sigma + sqrt(*sigma * *sigma + eta); + temp = tau + eta; + if (temp > sgub || temp < sglb) { + if (w < 0.) { + eta = (sgub - tau) / 2.; + } else { + eta = (sglb - tau) / 2.; + } + if (geomavg) { + if (w < 0.) { + if (tau > 0.) { + eta = sqrt(sgub * tau) - tau; + } + } else { + if (sglb > 0.) { + eta = sqrt(sglb * tau) - tau; + } + } + } + } + prew = w; + tau += eta; + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; +// L200: + } + // + // 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: + } + tau2 = work[ii] * delta[ii]; + temp = z__[ii] / tau2; + 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( TAU2 )*DW + // + if (w * prew > 0. && abs(w) > abs(prew) / 10.) { + swtch = ! swtch; + } +// L230: + } + // + // Return with INFO = 1, NITER = MAXIT and not converged + // + *info = 1; + } +L240: + return 0; + // + // End of DLASD4 + // +} // dlasd4_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD5 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) +// +// .. Scalar Arguments .. +// INTEGER I +// DOUBLE PRECISION DSIGMA, RHO +// .. +// .. Array Arguments .. +// DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] I +//> \verbatim +//> I is INTEGER +//> The index of the eigenvalue to be computed. I = 1 or I = 2. +//> \endverbatim +//> +//> \param[in] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension ( 2 ) +//> The original eigenvalues. We assume 0 <= D(1) < D(2). +//> \endverbatim +//> +//> \param[in] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension ( 2 ) +//> The components of the updating vector. +//> \endverbatim +//> +//> \param[out] DELTA +//> \verbatim +//> DELTA is 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. +//> \endverbatim +//> +//> \param[in] RHO +//> \verbatim +//> RHO is DOUBLE PRECISION +//> The scalar in the symmetric updating formula. +//> \endverbatim +//> +//> \param[out] DSIGMA +//> \verbatim +//> DSIGMA is DOUBLE PRECISION +//> The computed sigma_I, the I-th updated eigenvalue. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension ( 2 ) +//> WORK contains (D(j) + sigma_I) in its j-th component. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ren-Cang Li, Computer Science Division, University of California +//> at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd5_(int *i__, double *d__, double *z__, double * + delta, double *rho, double *dsigma, double *work) +{ + // System generated locals + double d__1; + + // Local variables + double b, c__, w, del, tau, delsq; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD6 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, +// IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, +// LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, +// IWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, +// $ NR, SQRE +// DOUBLE PRECISION ALPHA, BETA, C, S +// .. +// .. Array Arguments .. +// INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), +// $ PERM( * ) +// DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), +// $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), +// $ VF( * ), VL( * ), WORK( * ), Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T a Z2**T b ) * VT(in) +//> ( 0 0 D2(in) 0 ) +//> +//> = U(out) * ( D(out) 0) * VT(out) +//> +//> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, 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 occurrence 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] ICOMPQ +//> \verbatim +//> ICOMPQ is 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. +//> \endverbatim +//> +//> \param[in] NL +//> \verbatim +//> NL is INTEGER +//> The row dimension of the upper block. NL >= 1. +//> \endverbatim +//> +//> \param[in] NR +//> \verbatim +//> NR is INTEGER +//> The row dimension of the lower block. NR >= 1. +//> \endverbatim +//> +//> \param[in] SQRE +//> \verbatim +//> SQRE is 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. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[in,out] VF +//> \verbatim +//> VF is 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. +//> \endverbatim +//> +//> \param[in,out] VL +//> \verbatim +//> VL is 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. +//> \endverbatim +//> +//> \param[in,out] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION +//> Contains the diagonal element associated with the added row. +//> \endverbatim +//> +//> \param[in,out] BETA +//> \verbatim +//> BETA is DOUBLE PRECISION +//> Contains the off-diagonal element associated with the added +//> row. +//> \endverbatim +//> +//> \param[in,out] IDXQ +//> \verbatim +//> IDXQ is 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. +//> \endverbatim +//> +//> \param[out] PERM +//> \verbatim +//> PERM is INTEGER array, dimension ( N ) +//> The permutations (from deflation and sorting) to be applied +//> to each block. Not referenced if ICOMPQ = 0. +//> \endverbatim +//> +//> \param[out] GIVPTR +//> \verbatim +//> GIVPTR is INTEGER +//> The number of Givens rotations which took place in this +//> subproblem. Not referenced if ICOMPQ = 0. +//> \endverbatim +//> +//> \param[out] GIVCOL +//> \verbatim +//> GIVCOL is 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. +//> \endverbatim +//> +//> \param[in] LDGCOL +//> \verbatim +//> LDGCOL is INTEGER +//> leading dimension of GIVCOL, must be at least N. +//> \endverbatim +//> +//> \param[out] GIVNUM +//> \verbatim +//> GIVNUM is 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. +//> \endverbatim +//> +//> \param[in] LDGNUM +//> \verbatim +//> LDGNUM is INTEGER +//> The leading dimension of GIVNUM and POLES, must be at least N. +//> \endverbatim +//> +//> \param[out] POLES +//> \verbatim +//> POLES is 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. +//> \endverbatim +//> +//> \param[out] DIFL +//> \verbatim +//> DIFL is 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. +//> \endverbatim +//> +//> \param[out] DIFR +//> \verbatim +//> DIFR is 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. +//> +//> See DLASD8 for details on DIFL and DIFR. +//> \endverbatim +//> +//> \param[out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension ( M ) +//> The first elements of this array contain the components +//> of the deflation-adjusted updating row vector. +//> \endverbatim +//> +//> \param[out] K +//> \verbatim +//> K is INTEGER +//> Contains the dimension of the non-deflated matrix, +//> This is the order of the related secular equation. 1 <= K <=N. +//> \endverbatim +//> +//> \param[out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[out] S +//> \verbatim +//> S is 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. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension ( 4 * M ) +//> \endverbatim +//> +//> \param[out] IWORK +//> \verbatim +//> IWORK is INTEGER array, dimension ( 3 * N ) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: if INFO = 1, a singular value did not converge +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd6_(int *icompq, int *nl, int *nr, int *sqre, double + *d__, double *vf, double *vl, double *alpha, double *beta, int *idxq, + int *perm, int *givptr, int *givcol, int *ldgcol, double *givnum, int + *ldgnum, double *poles, double *difl, double *difr, double *z__, int * + k, double *c__, double *s, double *work, int *iwork, int *info) +{ + // Table of constant values + int c__0 = 0; + double c_b7 = 1.; + int c__1 = 1; + int c_n1 = -1; + + // System generated locals + int givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, poles_dim1, + poles_offset, i__1; + double d__1, d__2; + + // Local variables + int i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ), dlasd7_(int *, int *, int *, int *, int *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int *, int *, int *, int *, int *, int *, int + *, double *, int *, double *, double *, int *), dlasd8_(int *, + int *, double *, double *, double *, double *, double *, double *, + int *, double *, double *, int *), dlascl_(char *, int *, int *, + double *, double *, int *, int *, double *, int *, int *), + dlamrg_(int *, int *, double *, int *, int *, int *); + int isigma; + extern /* Subroutine */ int xerbla_(char *, int *); + double orgnrm; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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); + // + // Report the possible convergence failure. + // + if (*info != 0) { + return 0; + } + // + // 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD7 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, +// VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, +// PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, +// C, S, INFO ) +// +// .. Scalar Arguments .. +// INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, +// $ NR, SQRE +// DOUBLE PRECISION ALPHA, BETA, C, S +// .. +// .. Array Arguments .. +// INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), +// $ IDXQ( * ), PERM( * ) +// DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), +// $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), +// $ ZW( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] ICOMPQ +//> \verbatim +//> ICOMPQ is 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. +//> \endverbatim +//> +//> \param[in] NL +//> \verbatim +//> NL is INTEGER +//> The row dimension of the upper block. NL >= 1. +//> \endverbatim +//> +//> \param[in] NR +//> \verbatim +//> NR is INTEGER +//> The row dimension of the lower block. NR >= 1. +//> \endverbatim +//> +//> \param[in] SQRE +//> \verbatim +//> SQRE is 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. +//> \endverbatim +//> +//> \param[out] K +//> \verbatim +//> K is INTEGER +//> Contains the dimension of the non-deflated matrix, this is +//> the order of the related secular equation. 1 <= K <=N. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension ( M ) +//> On exit Z contains the updating row vector in the secular +//> equation. +//> \endverbatim +//> +//> \param[out] ZW +//> \verbatim +//> ZW is DOUBLE PRECISION array, dimension ( M ) +//> Workspace for Z. +//> \endverbatim +//> +//> \param[in,out] VF +//> \verbatim +//> VF is 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. +//> \endverbatim +//> +//> \param[out] VFW +//> \verbatim +//> VFW is DOUBLE PRECISION array, dimension ( M ) +//> Workspace for VF. +//> \endverbatim +//> +//> \param[in,out] VL +//> \verbatim +//> VL is 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. +//> \endverbatim +//> +//> \param[out] VLW +//> \verbatim +//> VLW is DOUBLE PRECISION array, dimension ( M ) +//> Workspace for VL. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION +//> Contains the diagonal element associated with the added row. +//> \endverbatim +//> +//> \param[in] BETA +//> \verbatim +//> BETA is DOUBLE PRECISION +//> Contains the off-diagonal element associated with the added +//> row. +//> \endverbatim +//> +//> \param[out] DSIGMA +//> \verbatim +//> DSIGMA is DOUBLE PRECISION array, dimension ( N ) +//> Contains a copy of the diagonal elements (K-1 singular values +//> and one zero) in the secular equation. +//> \endverbatim +//> +//> \param[out] IDX +//> \verbatim +//> IDX is INTEGER array, dimension ( N ) +//> This will contain the permutation used to sort the contents of +//> D into ascending order. +//> \endverbatim +//> +//> \param[out] IDXP +//> \verbatim +//> IDXP is 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. +//> \endverbatim +//> +//> \param[in] IDXQ +//> \verbatim +//> IDXQ is 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. +//> \endverbatim +//> +//> \param[out] PERM +//> \verbatim +//> PERM is INTEGER array, dimension ( N ) +//> The permutations (from deflation and sorting) to be applied +//> to each singular block. Not referenced if ICOMPQ = 0. +//> \endverbatim +//> +//> \param[out] GIVPTR +//> \verbatim +//> GIVPTR is INTEGER +//> The number of Givens rotations which took place in this +//> subproblem. Not referenced if ICOMPQ = 0. +//> \endverbatim +//> +//> \param[out] GIVCOL +//> \verbatim +//> GIVCOL is 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. +//> \endverbatim +//> +//> \param[in] LDGCOL +//> \verbatim +//> LDGCOL is INTEGER +//> The leading dimension of GIVCOL, must be at least N. +//> \endverbatim +//> +//> \param[out] GIVNUM +//> \verbatim +//> GIVNUM is 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. +//> \endverbatim +//> +//> \param[in] LDGNUM +//> \verbatim +//> LDGNUM is INTEGER +//> The leading dimension of GIVNUM, must be at least N. +//> \endverbatim +//> +//> \param[out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[out] S +//> \verbatim +//> S is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd7_(int *icompq, int *nl, int *nr, int *sqre, int *k, + double *d__, double *z__, double *zw, double *vf, double *vfw, + double *vl, double *vlw, double *alpha, double *beta, double *dsigma, + int *idx, int *idxp, int *idxq, int *perm, int *givptr, int *givcol, + int *ldgcol, double *givnum, int *ldgnum, double *c__, double *s, int + *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1; + double d__1, d__2; + + // Local variables + int i__, j, m, n, k2; + double z1; + int jp; + double eps, tau, tol; + int nlp1, nlp2, idxi, idxj; + extern /* Subroutine */ int drot_(int *, double *, int *, double *, int *, + double *, double *); + int idxjp; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + int jprev; + extern double dlapy2_(double *, double *), dlamch_(char *); + extern /* Subroutine */ int dlamrg_(int *, int *, double *, int *, int *, + int *), xerbla_(char *, int *); + double hlftol; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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 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 * 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASD8 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, +// DSIGMA, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER ICOMPQ, INFO, K, LDDIFR +// .. +// .. Array Arguments .. +// DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), +// $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), +// $ Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] ICOMPQ +//> \verbatim +//> ICOMPQ is 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. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of terms in the rational function to be solved +//> by DLASD4. K >= 1. +//> \endverbatim +//> +//> \param[out] D +//> \verbatim +//> D is DOUBLE PRECISION array, dimension ( K ) +//> On output, D contains the updated singular values. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is 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. +//> \endverbatim +//> +//> \param[in,out] VF +//> \verbatim +//> VF is 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. +//> \endverbatim +//> +//> \param[in,out] VL +//> \verbatim +//> VL is 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. +//> \endverbatim +//> +//> \param[out] DIFL +//> \verbatim +//> DIFL is DOUBLE PRECISION array, dimension ( K ) +//> On exit, DIFL(I) = D(I) - DSIGMA(I). +//> \endverbatim +//> +//> \param[out] DIFR +//> \verbatim +//> DIFR is 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. +//> \endverbatim +//> +//> \param[in] LDDIFR +//> \verbatim +//> LDDIFR is INTEGER +//> The leading dimension of DIFR, must be at least K. +//> \endverbatim +//> +//> \param[in,out] DSIGMA +//> \verbatim +//> DSIGMA is 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. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (3*K) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: if INFO = 1, a singular value did not converge +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasd8_(int *icompq, int *k, double *d__, double *z__, + double *vf, double *vl, double *difl, double *difr, int *lddifr, + double *dsigma, double *work, int *info) +{ + // Table of constant values + int c__1 = 1; + int c__0 = 0; + double c_b8 = 1.; + + // System generated locals + int difr_dim1, difr_offset, i__1, i__2; + double d__1, d__2; + + // Local variables + int i__, j; + double dj, rho; + int iwk1, iwk2, iwk3; + extern double ddot_(int *, double *, int *, double *, int *); + double temp; + extern double dnrm2_(int *, double *, int *); + int iwk2i, iwk3i; + double diflj, difrj, dsigj; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + extern double dlamc3_(double *, double *); + extern /* Subroutine */ int dlasd4_(int *, int *, double *, double *, + double *, double *, double *, double *, int *), dlascl_(char *, + int *, int *, double *, double *, int *, int *, double *, int *, + int *), dlaset_(char *, int *, int *, double *, double *, double * + , int *), xerbla_(char *, int *); + double dsigjp; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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, report the convergence failure. + // + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASDA + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, +// DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, +// PERM, GIVNUM, C, S, WORK, IWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE +// .. +// .. Array Arguments .. +// INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), +// $ K( * ), PERM( LDGCOL, * ) +// DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), +// $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), +// $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), +// $ Z( LDU, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] ICOMPQ +//> \verbatim +//> ICOMPQ is 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. +//> \endverbatim +//> +//> \param[in] SMLSIZ +//> \verbatim +//> SMLSIZ is INTEGER +//> The maximum size of the subproblems at the bottom of the +//> computation tree. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The row dimension of the upper bidiagonal matrix. This is +//> also the dimension of the main diagonal array D. +//> \endverbatim +//> +//> \param[in] SQRE +//> \verbatim +//> SQRE is 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. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[in] E +//> \verbatim +//> E is DOUBLE PRECISION array, dimension ( M-1 ) +//> Contains the subdiagonal entries of the bidiagonal matrix. +//> On exit, E has been destroyed. +//> \endverbatim +//> +//> \param[out] U +//> \verbatim +//> U is 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. +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is INTEGER, LDU = > N. +//> The leading dimension of arrays U, VT, DIFL, DIFR, POLES, +//> GIVNUM, and Z. +//> \endverbatim +//> +//> \param[out] VT +//> \verbatim +//> VT is DOUBLE PRECISION array, +//> dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced +//> if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right +//> singular vector matrices of all subproblems at the bottom +//> level. +//> \endverbatim +//> +//> \param[out] K +//> \verbatim +//> K is 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. +//> \endverbatim +//> +//> \param[out] DIFL +//> \verbatim +//> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ), +//> where NLVL = floor(log_2 (N/SMLSIZ))). +//> \endverbatim +//> +//> \param[out] DIFR +//> \verbatim +//> DIFR is 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. +//> \endverbatim +//> +//> \param[out] Z +//> \verbatim +//> Z is 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. +//> \endverbatim +//> +//> \param[out] POLES +//> \verbatim +//> POLES is 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. +//> \endverbatim +//> +//> \param[out] GIVPTR +//> \verbatim +//> GIVPTR is 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. +//> \endverbatim +//> +//> \param[out] GIVCOL +//> \verbatim +//> GIVCOL is 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. +//> \endverbatim +//> +//> \param[in] LDGCOL +//> \verbatim +//> LDGCOL is INTEGER, LDGCOL = > N. +//> The leading dimension of arrays GIVCOL and PERM. +//> \endverbatim +//> +//> \param[out] PERM +//> \verbatim +//> PERM is 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. +//> \endverbatim +//> +//> \param[out] GIVNUM +//> \verbatim +//> GIVNUM is 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. +//> \endverbatim +//> +//> \param[out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[out] S +//> \verbatim +//> S is 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. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension +//> (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). +//> \endverbatim +//> +//> \param[out] IWORK +//> \verbatim +//> IWORK is INTEGER array, dimension (7*N) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit. +//> < 0: if INFO = -i, the i-th argument had an illegal value. +//> > 0: if INFO = 1, a singular value did not converge +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasda_(int *icompq, int *smlsiz, int *n, int *sqre, + double *d__, double *e, double *u, int *ldu, double *vt, int *k, + double *difl, double *difr, double *z__, double *poles, int *givptr, + int *givcol, int *ldgcol, int *perm, double *givnum, double *c__, + double *s, double *work, int *iwork, int *info) +{ + // Table of constant values + int c__0 = 0; + double c_b11 = 0.; + double c_b12 = 1.; + int c__1 = 1; + int c__2 = 2; + + // System generated locals + int 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; + + // Local variables + int 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; + double beta; + int idxq, nlvl; + double alpha; + int inode, ndiml, ndimr, idxqi, itemp; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + int sqrei; + extern /* Subroutine */ int dlasd6_(int *, int *, int *, int *, double *, + double *, double *, double *, double *, int *, int *, int *, int * + , int *, double *, int *, double *, double *, double *, double *, + int *, double *, double *, double *, int *, int *); + int nwork1, nwork2; + extern /* Subroutine */ int dlasdq_(char *, int *, int *, int *, int *, + int *, double *, double *, double *, int *, double *, int *, + double *, int *, double *, int *), dlasdt_(int *, int *, int *, + int *, int *, int *, int *), dlaset_(char *, int *, int *, double + *, double *, double *, int *), xerbla_(char *, int *); + int smlszp; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASDQ + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, +// U, LDU, C, LDC, WORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER UPLO +// INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE +// .. +// .. Array Arguments .. +// DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), +// $ VT( LDVT, * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T (P**T 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**T * VT if desired. +//> The input matrix C is changed to Q**T * 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] UPLO +//> \verbatim +//> UPLO is CHARACTER*1 +//> On entry, UPLO specifies whether the input bidiagonal matrix +//> is upper or lower bidiagonal, and whether it is square are +//> not. +//> UPLO = 'U' or 'u' B is upper bidiagonal. +//> UPLO = 'L' or 'l' B is lower bidiagonal. +//> \endverbatim +//> +//> \param[in] SQRE +//> \verbatim +//> SQRE is 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. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> On entry, N specifies the number of rows and columns +//> in the matrix. N must be at least 0. +//> \endverbatim +//> +//> \param[in] NCVT +//> \verbatim +//> NCVT is INTEGER +//> On entry, NCVT specifies the number of columns of +//> the matrix VT. NCVT must be at least 0. +//> \endverbatim +//> +//> \param[in] NRU +//> \verbatim +//> NRU is INTEGER +//> On entry, NRU specifies the number of rows of +//> the matrix U. NRU must be at least 0. +//> \endverbatim +//> +//> \param[in] NCC +//> \verbatim +//> NCC is INTEGER +//> On entry, NCC specifies the number of columns of +//> the matrix C. NCC must be at least 0. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[in,out] E +//> \verbatim +//> E is 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. +//> \endverbatim +//> +//> \param[in,out] VT +//> \verbatim +//> VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) +//> On entry, contains a matrix which on exit has been +//> premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 +//> and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). +//> \endverbatim +//> +//> \param[in] LDVT +//> \verbatim +//> LDVT is 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. +//> \endverbatim +//> +//> \param[in,out] U +//> \verbatim +//> U is 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). +//> \endverbatim +//> +//> \param[in] LDU +//> \verbatim +//> LDU is 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 ) . +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is DOUBLE PRECISION array, dimension (LDC, NCC) +//> On entry, contains an N-by-NCC matrix which on exit +//> has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 +//> and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is 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. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is 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. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasdq_(char *uplo, int *sqre, int *n, int *ncvt, int * + nru, int *ncc, double *d__, double *e, double *vt, int *ldvt, double * + u, int *ldu, double *c__, int *ldc, double *work, int *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + + // Local variables + int i__, j; + double r__, cs, sn; + int np1, isub; + double smin; + int sqre1; + extern int lsame_(char *, char *); + extern /* Subroutine */ int dlasr_(char *, char *, char *, int *, int *, + double *, double *, double *, int *), dswap_(int *, double *, int + *, double *, int *); + int iuplo; + extern /* Subroutine */ int dlartg_(double *, double *, double *, double * + , double *), xerbla_(char *, int *), dbdsqr_(char *, int *, int *, + int *, int *, double *, double *, double *, int *, double *, int + *, double *, int *, double *, int *); + int rotate; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASDT + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) +// +// .. Scalar Arguments .. +// INTEGER LVL, MSUB, N, ND +// .. +// .. Array Arguments .. +// INTEGER INODE( * ), NDIML( * ), NDIMR( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLASDT creates a tree of subproblems for bidiagonal divide and +//> conquer. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> On entry, the number of diagonal elements of the +//> bidiagonal matrix. +//> \endverbatim +//> +//> \param[out] LVL +//> \verbatim +//> LVL is INTEGER +//> On exit, the number of levels on the computation tree. +//> \endverbatim +//> +//> \param[out] ND +//> \verbatim +//> ND is INTEGER +//> On exit, the number of nodes on the tree. +//> \endverbatim +//> +//> \param[out] INODE +//> \verbatim +//> INODE is INTEGER array, dimension ( N ) +//> On exit, centers of subproblems. +//> \endverbatim +//> +//> \param[out] NDIML +//> \verbatim +//> NDIML is INTEGER array, dimension ( N ) +//> On exit, row dimensions of left children. +//> \endverbatim +//> +//> \param[out] NDIMR +//> \verbatim +//> NDIMR is INTEGER array, dimension ( N ) +//> On exit, row dimensions of right children. +//> \endverbatim +//> +//> \param[in] MSUB +//> \verbatim +//> MSUB is INTEGER +//> On entry, the maximum row dimension each subproblem at the +//> bottom of the tree can be of. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Contributors: +// ================== +//> +//> Ming Gu and Huan Ren, Computer Science Division, University of +//> California at Berkeley, USA +//> +// ===================================================================== +/* Subroutine */ int dlasdt_(int *n, int *lvl, int *nd, int *inode, int * + ndiml, int *ndimr, int *msub) +{ + // System generated locals + int i__1, i__2; + + // Local variables + int i__, il, ir, maxn; + double temp; + int nlvl, llst, ncrnt; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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((double) maxn / (double) (*msub + 1)) / log(2.); + *lvl = (int) 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASQ1 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION D( * ), E( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of rows and columns in the matrix. N >= 0. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[in,out] E +//> \verbatim +//> E is 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. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (4*N) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is 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 100*N +//> iterations (in inner while loop) On exit D and E +//> represent a matrix with the same singular values +//> which the calling subroutine could use to finish the +//> computation, or even feed back into DLASQ1 +//> = 3, termination criterion of outer while loop not met +//> (program created more than N unreduced blocks) +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup auxOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dlasq1_(int *n, double *d__, double *e, double *work, + int *info) +{ + // Table of constant values + int c__1 = 1; + int c__2 = 2; + int c__0 = 0; + + // System generated locals + int i__1, i__2; + double d__1, d__2, d__3; + + // Local variables + int i__; + double eps; + extern /* Subroutine */ int dlas2_(double *, double *, double *, double *, + double *); + double scale; + int iinfo; + double sigmn; + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ); + double sigmx; + extern /* Subroutine */ int dlasq2_(int *, double *, int *); + extern double dlamch_(char *); + extern /* Subroutine */ int dlascl_(char *, int *, int *, double *, + double *, int *, int *, double *, int *, int *); + double safmin; + extern /* Subroutine */ int xerbla_(char *, int *), dlasrt_(char *, int *, + double *, int *); + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Subroutines .. + // .. + // .. External Functions .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Parameter adjustments + --work; + --e; + --d__; + + // Function Body + *info = 0; + if (*n < 0) { + *info = -1; + 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); + } else if (*info == 2) { + // + // Maximum number of iterations exceeded. Move data from WORK + // into D and E so the calling subroutine can try to finish + // + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(work[(i__ << 1) - 1]); + e[i__] = sqrt(work[i__ * 2]); + } + dlascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & + iinfo); + dlascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo) + ; + } + return 0; + // + // End of DLASQ1 + // +} // dlasq1_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASQ2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASQ2( N, Z, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of rows and columns in the matrix. N >= 0. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is 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 100*N +//> iterations (in inner while loop). On exit Z holds +//> a qd array with the same eigenvalues as the given Z. +//> = 3, termination criterion of outer while loop not met +//> (program created more than N unreduced blocks) +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup auxOTHERcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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). +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlasq2_(int *n, double *z__, int *info) +{ + // Table of constant values + int c__1 = 1; + int c__2 = 2; + int c__10 = 10; + int c__3 = 3; + int c__4 = 4; + int c__11 = 11; + + // System generated locals + int i__1, i__2, i__3; + double d__1, d__2; + + // Local variables + double d__, e, g; + int k; + double s, t; + int i0, i1, i4, n0, n1; + double dn; + int pp; + double dn1, dn2, dee, eps, tau, tol; + int ipn4; + double tol2; + int ieee; + int nbig; + double dmin__, emin, emax; + int kmin, ndiv, iter; + double qmin, temp, qmax, zmax; + int splt; + double dmin1, dmin2; + int nfail; + double desig, trace, sigma; + int iinfo; + double tempe, tempq; + int ttype; + extern /* Subroutine */ int dlasq3_(int *, int *, double *, int *, double + *, double *, double *, double *, int *, int *, int *, int *, int * + , double *, double *, double *, double *, double *, double *, + double *); + extern double dlamch_(char *); + double deemin; + int iwhila, iwhilb; + double oldemn, safmin; + extern /* Subroutine */ int xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + extern /* Subroutine */ int dlasrt_(char *, int *, double *, int *); + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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) * 100; + 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; + // + // Maximum number of iterations exceeded, restore the shift + // SIGMA and place the new d's and e's in a qd array. + // This might need to be done for several blocks + // + i1 = i0; + n1 = n0; +L145: + tempq = z__[(i0 << 2) - 3]; + z__[(i0 << 2) - 3] += sigma; + i__2 = n0; + for (k = i0 + 1; k <= i__2; ++k) { + tempe = z__[(k << 2) - 5]; + z__[(k << 2) - 5] *= tempq / z__[(k << 2) - 7]; + tempq = z__[(k << 2) - 3]; + z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k << + 2) - 5]; + } + // + // Prepare to do this on the previous block if there is one + // + if (i1 > 1) { + n1 = i1 - 1; + while(i1 >= 2 && z__[(i1 << 2) - 5] >= 0.) { + --i1; + } + sigma = -z__[(n1 << 2) - 1]; + goto L145; + } + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + z__[(k << 1) - 1] = z__[(k << 2) - 3]; + // + // Only the block 1..N0 is unfinished. The rest of the e's + // must be essentially zero, although sometimes other data + // has been stored in them. + // + if (k < n0) { + z__[k * 2] = z__[(k << 2) - 1]; + } else { + z__[k * 2] = 0.; + } + } + 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] = (double) iter; + // Computing 2nd power + i__1 = *n; + z__[(*n << 1) + 4] = (double) ndiv / (double) (i__1 * i__1); + z__[(*n << 1) + 5] = nfail * 100. / (double) iter; + return 0; + // + // End of DLASQ2 + // +} // dlasq2_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASQ3 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, +// ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, +// DN2, G, TAU ) +// +// .. Scalar Arguments .. +// LOGICAL IEEE +// INTEGER I0, ITER, N0, NDIV, NFAIL, PP +// DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, +// $ QMAX, SIGMA, TAU +// .. +// .. Array Arguments .. +// DOUBLE PRECISION Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] I0 +//> \verbatim +//> I0 is INTEGER +//> First index. +//> \endverbatim +//> +//> \param[in,out] N0 +//> \verbatim +//> N0 is INTEGER +//> Last index. +//> \endverbatim +//> +//> \param[in,out] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) +//> Z holds the qd array. +//> \endverbatim +//> +//> \param[in,out] PP +//> \verbatim +//> PP is 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. +//> \endverbatim +//> +//> \param[out] DMIN +//> \verbatim +//> DMIN is DOUBLE PRECISION +//> Minimum value of d. +//> \endverbatim +//> +//> \param[out] SIGMA +//> \verbatim +//> SIGMA is DOUBLE PRECISION +//> Sum of shifts used in current segment. +//> \endverbatim +//> +//> \param[in,out] DESIG +//> \verbatim +//> DESIG is DOUBLE PRECISION +//> Lower order part of SIGMA +//> \endverbatim +//> +//> \param[in] QMAX +//> \verbatim +//> QMAX is DOUBLE PRECISION +//> Maximum value of q. +//> \endverbatim +//> +//> \param[in,out] NFAIL +//> \verbatim +//> NFAIL is INTEGER +//> Increment NFAIL by 1 each time the shift was too big. +//> \endverbatim +//> +//> \param[in,out] ITER +//> \verbatim +//> ITER is INTEGER +//> Increment ITER by 1 for each iteration. +//> \endverbatim +//> +//> \param[in,out] NDIV +//> \verbatim +//> NDIV is INTEGER +//> Increment NDIV by 1 for each division. +//> \endverbatim +//> +//> \param[in] IEEE +//> \verbatim +//> IEEE is LOGICAL +//> Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). +//> \endverbatim +//> +//> \param[in,out] TTYPE +//> \verbatim +//> TTYPE is INTEGER +//> Shift type. +//> \endverbatim +//> +//> \param[in,out] DMIN1 +//> \verbatim +//> DMIN1 is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] DMIN2 +//> \verbatim +//> DMIN2 is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] DN +//> \verbatim +//> DN is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] DN1 +//> \verbatim +//> DN1 is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] DN2 +//> \verbatim +//> DN2 is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] G +//> \verbatim +//> G is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in,out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION +//> +//> These are passed as arguments in order to save their values +//> between calls to DLASQ3. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup auxOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dlasq3_(int *i0, int *n0, double *z__, int *pp, double * + dmin__, double *sigma, double *desig, double *qmax, int *nfail, int * + iter, int *ndiv, int *ieee, int *ttype, double *dmin1, double *dmin2, + double *dn, double *dn1, double *dn2, double *g, double *tau) +{ + // System generated locals + int i__1; + double d__1, d__2; + + // Local variables + double s, t; + int j4, nn; + double eps, tol; + int n0in, ipn4; + double tol2, temp; + extern /* Subroutine */ int dlasq4_(int *, int *, double *, int *, int *, + double *, double *, double *, double *, double *, double *, + double *, int *, double *), dlasq5_(int *, int *, double *, int *, + double *, double *, double *, double *, double *, double *, + double *, double *, int *, double *), dlasq6_(int *, int *, + double *, int *, double *, double *, double *, double *, double *, + double *); + extern double dlamch_(char *); + extern int disnan_(double *); + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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; + } + t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; + if (z__[nn - 5] > z__[nn - 3] * tol2 && t != 0.) { + 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, sigma, dmin__, dmin1, dmin2, dn, dn1, + dn2, ieee, &eps); + *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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASQ4 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, +// DN1, DN2, TAU, TTYPE, G ) +// +// .. Scalar Arguments .. +// INTEGER I0, N0, N0IN, PP, TTYPE +// DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU +// .. +// .. Array Arguments .. +// DOUBLE PRECISION Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLASQ4 computes an approximation TAU to the smallest eigenvalue +//> using values of d from the previous transform. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] I0 +//> \verbatim +//> I0 is INTEGER +//> First index. +//> \endverbatim +//> +//> \param[in] N0 +//> \verbatim +//> N0 is INTEGER +//> Last index. +//> \endverbatim +//> +//> \param[in] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) +//> Z holds the qd array. +//> \endverbatim +//> +//> \param[in] PP +//> \verbatim +//> PP is INTEGER +//> PP=0 for ping, PP=1 for pong. +//> \endverbatim +//> +//> \param[in] N0IN +//> \verbatim +//> N0IN is INTEGER +//> The value of N0 at start of EIGTEST. +//> \endverbatim +//> +//> \param[in] DMIN +//> \verbatim +//> DMIN is DOUBLE PRECISION +//> Minimum value of d. +//> \endverbatim +//> +//> \param[in] DMIN1 +//> \verbatim +//> DMIN1 is DOUBLE PRECISION +//> Minimum value of d, excluding D( N0 ). +//> \endverbatim +//> +//> \param[in] DMIN2 +//> \verbatim +//> DMIN2 is DOUBLE PRECISION +//> Minimum value of d, excluding D( N0 ) and D( N0-1 ). +//> \endverbatim +//> +//> \param[in] DN +//> \verbatim +//> DN is DOUBLE PRECISION +//> d(N) +//> \endverbatim +//> +//> \param[in] DN1 +//> \verbatim +//> DN1 is DOUBLE PRECISION +//> d(N-1) +//> \endverbatim +//> +//> \param[in] DN2 +//> \verbatim +//> DN2 is DOUBLE PRECISION +//> d(N-2) +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION +//> This is the shift. +//> \endverbatim +//> +//> \param[out] TTYPE +//> \verbatim +//> TTYPE is INTEGER +//> Shift type. +//> \endverbatim +//> +//> \param[in,out] G +//> \verbatim +//> G is DOUBLE PRECISION +//> G is passed as an argument in order to save its value between +//> calls to DLASQ4. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup auxOTHERcomputational +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> CNST1 = 9/16 +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlasq4_(int *i0, int *n0, double *z__, int *pp, int * + n0in, double *dmin__, double *dmin1, double *dmin2, double *dn, + double *dn1, double *dn2, double *tau, int *ttype, double *g) +{ + // System generated locals + int i__1; + double d__1, d__2; + + // Local variables + double s, a2, b1, b2; + int i4, nn, np; + double gam, gap1, gap2; + + // + // -- LAPACK computational routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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); + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASQ5 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, +// DNM1, DNM2, IEEE, EPS ) +// +// .. Scalar Arguments .. +// LOGICAL IEEE +// INTEGER I0, N0, PP +// DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, SIGMA, EPS +// .. +// .. Array Arguments .. +// DOUBLE PRECISION Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLASQ5 computes one dqds transform in ping-pong form, one +//> version for IEEE machines another for non IEEE machines. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] I0 +//> \verbatim +//> I0 is INTEGER +//> First index. +//> \endverbatim +//> +//> \param[in] N0 +//> \verbatim +//> N0 is INTEGER +//> Last index. +//> \endverbatim +//> +//> \param[in] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension ( 4*N ) +//> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid +//> an extra argument. +//> \endverbatim +//> +//> \param[in] PP +//> \verbatim +//> PP is INTEGER +//> PP=0 for ping, PP=1 for pong. +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION +//> This is the shift. +//> \endverbatim +//> +//> \param[in] SIGMA +//> \verbatim +//> SIGMA is DOUBLE PRECISION +//> This is the accumulated shift up to this step. +//> \endverbatim +//> +//> \param[out] DMIN +//> \verbatim +//> DMIN is DOUBLE PRECISION +//> Minimum value of d. +//> \endverbatim +//> +//> \param[out] DMIN1 +//> \verbatim +//> DMIN1 is DOUBLE PRECISION +//> Minimum value of d, excluding D( N0 ). +//> \endverbatim +//> +//> \param[out] DMIN2 +//> \verbatim +//> DMIN2 is DOUBLE PRECISION +//> Minimum value of d, excluding D( N0 ) and D( N0-1 ). +//> \endverbatim +//> +//> \param[out] DN +//> \verbatim +//> DN is DOUBLE PRECISION +//> d(N0), the last value of d. +//> \endverbatim +//> +//> \param[out] DNM1 +//> \verbatim +//> DNM1 is DOUBLE PRECISION +//> d(N0-1). +//> \endverbatim +//> +//> \param[out] DNM2 +//> \verbatim +//> DNM2 is DOUBLE PRECISION +//> d(N0-2). +//> \endverbatim +//> +//> \param[in] IEEE +//> \verbatim +//> IEEE is LOGICAL +//> Flag for IEEE or non IEEE arithmetic. +//> \endverbatim +//> +//> \param[in] EPS +//> \verbatim +//> EPS is DOUBLE PRECISION +//> This is the value of epsilon used. +//> \endverbatim +//> +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup auxOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dlasq5_(int *i0, int *n0, double *z__, int *pp, double * + tau, double *sigma, double *dmin__, double *dmin1, double *dmin2, + double *dn, double *dnm1, double *dnm2, int *ieee, double *eps) +{ + // System generated locals + int i__1; + double d__1, d__2; + + // Local variables + double d__; + int j4, j4p2; + double emin, temp, dthresh; + + // + // -- LAPACK computational routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameter .. + // .. + // .. Local Scalars .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Parameter adjustments + --z__; + + // Function Body + if (*n0 - *i0 - 1 <= 0) { + return 0; + } + dthresh = *eps * (*sigma + *tau); + if (*tau < dthresh * .5) { + *tau = 0.; + } + if (*tau != 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); + } + } else { + // This is the version that sets d's to zero if they are small enough + 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; + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__,d__); + z__[j4] = z__[j4 - 1] * temp; + // Computing MIN + d__1 = z__[j4]; + emin = min(d__1,emin); +// L50: + } + } 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; + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__,d__); + z__[j4 - 1] = z__[j4] * temp; + // Computing MIN + d__1 = z__[j4 - 1]; + emin = min(d__1,emin); +// L60: + } + } + // + // 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; + } + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__,d__); + // Computing MIN + d__1 = emin, d__2 = z__[j4]; + emin = min(d__1,d__2); +// L70: + } + } 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; + } + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__,d__); + // Computing MIN + d__1 = emin, d__2 = z__[j4 - 1]; + emin = min(d__1,d__2); +// L80: + } + } + // + // 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASQ6 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, +// DNM1, DNM2 ) +// +// .. Scalar Arguments .. +// INTEGER I0, N0, PP +// DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 +// .. +// .. Array Arguments .. +// DOUBLE PRECISION Z( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLASQ6 computes one dqd (shift equal to zero) transform in +//> ping-pong form, with protection against underflow and overflow. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] I0 +//> \verbatim +//> I0 is INTEGER +//> First index. +//> \endverbatim +//> +//> \param[in] N0 +//> \verbatim +//> N0 is INTEGER +//> Last index. +//> \endverbatim +//> +//> \param[in] Z +//> \verbatim +//> Z is DOUBLE PRECISION array, dimension ( 4*N ) +//> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid +//> an extra argument. +//> \endverbatim +//> +//> \param[in] PP +//> \verbatim +//> PP is INTEGER +//> PP=0 for ping, PP=1 for pong. +//> \endverbatim +//> +//> \param[out] DMIN +//> \verbatim +//> DMIN is DOUBLE PRECISION +//> Minimum value of d. +//> \endverbatim +//> +//> \param[out] DMIN1 +//> \verbatim +//> DMIN1 is DOUBLE PRECISION +//> Minimum value of d, excluding D( N0 ). +//> \endverbatim +//> +//> \param[out] DMIN2 +//> \verbatim +//> DMIN2 is DOUBLE PRECISION +//> Minimum value of d, excluding D( N0 ) and D( N0-1 ). +//> \endverbatim +//> +//> \param[out] DN +//> \verbatim +//> DN is DOUBLE PRECISION +//> d(N0), the last value of d. +//> \endverbatim +//> +//> \param[out] DNM1 +//> \verbatim +//> DNM1 is DOUBLE PRECISION +//> d(N0-1). +//> \endverbatim +//> +//> \param[out] DNM2 +//> \verbatim +//> DNM2 is DOUBLE PRECISION +//> d(N0-2). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup auxOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dlasq6_(int *i0, int *n0, double *z__, int *pp, double * + dmin__, double *dmin1, double *dmin2, double *dn, double *dnm1, + double *dnm2) +{ + // System generated locals + int i__1; + double d__1, d__2; + + // Local variables + double d__; + int j4, j4p2; + double emin, temp; + extern double dlamch_(char *); + double safmin; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) +// +// .. Scalar Arguments .. +// CHARACTER DIRECT, PIVOT, SIDE +// INTEGER LDA, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is 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 +//> \endverbatim +//> +//> \param[in] PIVOT +//> \verbatim +//> PIVOT is 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) +//> \endverbatim +//> +//> \param[in] DIRECT +//> \verbatim +//> DIRECT is 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) +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. If m <= 1, an immediate +//> return is effected. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. If n <= 1, an +//> immediate return is effected. +//> \endverbatim +//> +//> \param[in] C +//> \verbatim +//> C is DOUBLE PRECISION array, dimension +//> (M-1) if SIDE = 'L' +//> (N-1) if SIDE = 'R' +//> The cosines c(k) of the plane rotations. +//> \endverbatim +//> +//> \param[in] S +//> \verbatim +//> S is 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) ). +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> The M-by-N matrix A. On exit, A is overwritten by P*A if +//> SIDE = 'L' or by A*P**T if SIDE = 'R'. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, int *m, + int *n, double *c__, double *s, double *a, int *lda) +{ + // System generated locals + int a_dim1, a_offset, i__1, i__2; + + // Local variables + int i__, j, info; + double temp; + extern int lsame_(char *, char *); + double ctemp, stemp; + extern /* Subroutine */ int xerbla_(char *, int *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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**T + // + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASRT sorts numbers in increasing or decreasing order. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASRT + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASRT( ID, N, D, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER ID +// INTEGER INFO, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION D( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] ID +//> \verbatim +//> ID is CHARACTER*1 +//> = 'I': sort D in increasing order; +//> = 'D': sort D in decreasing order. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The length of the array D. +//> \endverbatim +//> +//> \param[in,out] D +//> \verbatim +//> D is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup auxOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dlasrt_(char *id, int *n, double *d__, int *info) +{ + // System generated locals + int i__1, i__2; + + // Local variables + int i__, j; + double d1, d2, d3; + int dir; + double tmp; + int endd; + extern int lsame_(char *, char *); + int stack[64] /* was [2][32] */; + double dmnmx; + int start; + extern /* Subroutine */ int xerbla_(char *, int *); + int stkpnt; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. Local Arrays .. + // .. + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Executable Statements .. + // + // Test the input parameters. + // + // 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASV2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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 ]. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] F +//> \verbatim +//> F is DOUBLE PRECISION +//> The (1,1) element of the 2-by-2 matrix. +//> \endverbatim +//> +//> \param[in] G +//> \verbatim +//> G is DOUBLE PRECISION +//> The (1,2) element of the 2-by-2 matrix. +//> \endverbatim +//> +//> \param[in] H +//> \verbatim +//> H is DOUBLE PRECISION +//> The (2,2) element of the 2-by-2 matrix. +//> \endverbatim +//> +//> \param[out] SSMIN +//> \verbatim +//> SSMIN is DOUBLE PRECISION +//> abs(SSMIN) is the smaller singular value. +//> \endverbatim +//> +//> \param[out] SSMAX +//> \verbatim +//> SSMAX is DOUBLE PRECISION +//> abs(SSMAX) is the larger singular value. +//> \endverbatim +//> +//> \param[out] SNL +//> \verbatim +//> SNL is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[out] CSL +//> \verbatim +//> CSL is DOUBLE PRECISION +//> The vector (CSL, SNL) is a unit left singular vector for the +//> singular value abs(SSMAX). +//> \endverbatim +//> +//> \param[out] SNR +//> \verbatim +//> SNR is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[out] CSR +//> \verbatim +//> CSR is DOUBLE PRECISION +//> The vector (CSR, SNR) is a unit right singular vector for the +//> singular value abs(SSMAX). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlasv2_(double *f, double *g, double *h__, double *ssmin, + double *ssmax, double *snr, double *csr, double *snl, double *csl) +{ + // Table of constant values + double c_b3 = 2.; + double c_b4 = 1.; + + // System generated locals + double d__1; + + // Local variables + double a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, crt, + slt, srt; + int pmax; + double temp; + int swap; + double tsign; + extern double dlamch_(char *); + int gasmal; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // + //===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORGBR +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORGBR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER VECT +// INTEGER INFO, K, LDA, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] VECT +//> \verbatim +//> VECT is 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. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix Q or P**T to be returned. +//> M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is 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). +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is 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. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is 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. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date April 2012 +// +//> \ingroup doubleGBcomputational +// +// ===================================================================== +/* Subroutine */ int dorgbr_(char *vect, int *m, int *n, int *k, double *a, + int *lda, double *tau, double *work, int *lwork, int *info) +{ + // Table of constant values + int c_n1 = -1; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3; + + // Local variables + int i__, j, mn; + extern int lsame_(char *, char *); + int iinfo; + int wantq; + extern /* Subroutine */ int xerbla_(char *, int *), dorglq_(int *, int *, + int *, double *, int *, double *, double *, int *, int *), + dorgqr_(int *, int *, int *, double *, int *, double *, double *, + int *, int *); + int lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // April 2012 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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) { + work[1] = 1.; + if (wantq) { + if (*m >= *k) { + dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, + &iinfo); + } else { + if (*m > 1) { + 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], &c_n1, &iinfo); + } + } + } else { + if (*k < *n) { + dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, + &iinfo); + } else { + if (*n > 1) { + 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], &c_n1, &iinfo); + } + } + } + lwkopt = (int) work[1]; + lwkopt = max(lwkopt,mn); + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGBR", &i__1); + return 0; + } else if (lquery) { + work[1] = (double) lwkopt; + 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**T, 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**T 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**T(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] = (double) lwkopt; + return 0; + // + // End of DORGBR + // +} // dorgbr_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORGL2 +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORGL2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, K, LDA, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix Q. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix Q. N >= M. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of elementary reflectors whose product defines the +//> matrix Q. M >= K >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The first dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGELQF. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (M) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument has an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dorgl2_(int *m, int *n, int *k, double *a, int *lda, + double *tau, double *work, int *info) +{ + // System generated locals + int a_dim1, a_offset, i__1, i__2; + double d__1; + + // Local variables + int i__, j, l; + extern /* Subroutine */ int dscal_(int *, double *, double *, int *), + dlarf_(char *, int *, int *, double *, int *, double *, double *, + int *, double *), xerbla_(char *, int *); + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORGLQ +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORGLQ + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, K, LDA, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix Q. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix Q. N >= M. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of elementary reflectors whose product defines the +//> matrix Q. M >= K >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The first dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGELQF. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument has an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dorglq_(int *m, int *n, int *k, double *a, int *lda, + double *tau, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__3 = 3; + int c__2 = 2; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3; + + // Local variables + int i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; + extern /* Subroutine */ int dorgl2_(int *, int *, int *, double *, int *, + double *, double *, int *), dlarfb_(char *, char *, char *, char * + , int *, int *, int *, double *, int *, double *, int *, double *, + int *, double *, int *), dlarft_(char *, char *, int *, int *, + double *, int *, double *, double *, int *), xerbla_(char *, int * + ); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + int ldwork, lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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] = (double) 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**T 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**T 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] = (double) iws; + return 0; + // + // End of DORGLQ + // +} // dorglq_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORMBR +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORMBR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, +// LDC, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER SIDE, TRANS, VECT +// INTEGER INFO, K, LDA, LDC, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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). +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] VECT +//> \verbatim +//> VECT is CHARACTER*1 +//> = 'Q': apply Q or Q**T; +//> = 'P': apply P or P**T. +//> \endverbatim +//> +//> \param[in] SIDE +//> \verbatim +//> SIDE is 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. +//> \endverbatim +//> +//> \param[in] TRANS +//> \verbatim +//> TRANS is CHARACTER*1 +//> = 'N': No transpose, apply Q or P; +//> = 'T': Transpose, apply Q**T or P**T. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. N >= 0. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is 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. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. +//> If VECT = 'Q', LDA >= max(1,nq); +//> if VECT = 'P', LDA >= max(1,min(nq,K)). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is 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. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= max(1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, int *m, int + *n, int *k, double *a, int *lda, double *tau, double *c__, int *ldc, + double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__2 = 2; + + // System generated locals + address a__1[2]; + int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; + char ch__1[2+1]={'\0'}; + + // Local variables + int i1, i2, nb, mi, ni, nq, nw; + int left; + extern int lsame_(char *, char *); + int iinfo; + extern /* Subroutine */ int xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + extern /* Subroutine */ int dormlq_(char *, char *, int *, int *, int *, + double *, int *, double *, double *, int *, double *, int *, int * + ); + int notran; + extern /* Subroutine */ int dormqr_(char *, char *, int *, int *, int *, + double *, int *, double *, double *, int *, double *, int *, int * + ); + int applyq; + char transt[1+1]={'\0'}; + int lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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); + 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); + 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); + 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); + 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] = (double) 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] = (double) lwkopt; + return 0; + // + // End of DORMBR + // +} // dormbr_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORML2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +// WORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER SIDE, TRANS +// INTEGER INFO, K, LDA, LDC, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DORML2 overwrites the general real m by n matrix C with +//> +//> Q * C if SIDE = 'L' and TRANS = 'N', or +//> +//> Q**T* C if SIDE = 'L' and TRANS = 'T', or +//> +//> C * Q if SIDE = 'R' and TRANS = 'N', or +//> +//> C * Q**T 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'. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'L': apply Q or Q**T from the Left +//> = 'R': apply Q or Q**T from the Right +//> \endverbatim +//> +//> \param[in] TRANS +//> \verbatim +//> TRANS is CHARACTER*1 +//> = 'N': apply Q (No transpose) +//> = 'T': apply Q**T (Transpose) +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. N >= 0. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of elementary reflectors whose product defines +//> the matrix Q. +//> If SIDE = 'L', M >= K >= 0; +//> if SIDE = 'R', N >= K >= 0. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,K). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGELQF. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= max(1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension +//> (N) if SIDE = 'L', +//> (M) if SIDE = 'R' +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dorml2_(char *side, char *trans, int *m, int *n, int *k, + double *a, int *lda, double *tau, double *c__, int *ldc, double *work, + int *info) +{ + // System generated locals + int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + + // Local variables + int i__, i1, i2, i3, ic, jc, mi, ni, nq; + double aii; + int left; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *); + extern int lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, int *); + int notran; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORMLQ +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORMLQ + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +// WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER SIDE, TRANS +// INTEGER INFO, K, LDA, LDC, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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'. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'L': apply Q or Q**T from the Left; +//> = 'R': apply Q or Q**T from the Right. +//> \endverbatim +//> +//> \param[in] TRANS +//> \verbatim +//> TRANS is CHARACTER*1 +//> = 'N': No transpose, apply Q; +//> = 'T': Transpose, apply Q**T. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. N >= 0. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of elementary reflectors whose product defines +//> the matrix Q. +//> If SIDE = 'L', M >= K >= 0; +//> if SIDE = 'R', N >= K >= 0. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,K). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGELQF. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= max(1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the array WORK. +//> If SIDE = 'L', LWORK >= max(1,N); +//> if SIDE = 'R', LWORK >= max(1,M). +//> 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dormlq_(char *side, char *trans, int *m, int *n, int *k, + double *a, int *lda, double *tau, double *c__, int *ldc, double *work, + int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__2 = 2; + int c__65 = 65; + + // System generated locals + address a__1[2]; + int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5; + char ch__1[2+1]={'\0'}; + + // Local variables + int i__, i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iwt; + int left; + extern int lsame_(char *, char *); + int nbmin, iinfo; + extern /* Subroutine */ int dorml2_(char *, char *, int *, int *, int *, + double *, int *, double *, double *, int *, double *, int *), + dlarfb_(char *, char *, char *, char *, int *, int *, int *, + double *, int *, double *, int *, double *, int *, double *, int * + ), dlarft_(char *, char *, int *, int *, double *, int *, double * + , double *, int *), xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + int notran; + int ldwork; + char transt[1+1]={'\0'}; + int lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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"); + 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) { + // + // Compute the workspace requirements + // + // 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); + 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 + 4160; + work[1] = (double) 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) { + if (*lwork < nw * nb + 4160) { + nb = (*lwork - 4160) / 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); + i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1); + nbmin = max(i__1,i__2); + } + } + 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 + // + iwt = nw * nb + 1; + 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__], &work[iwt], &c__65); + if (left) { + // + // H or H**T is applied to C(i:m,1:n) + // + mi = *m - i__ + 1; + ic = i__; + } else { + // + // H or H**T is applied to C(1:m,i:n) + // + ni = *n - i__ + 1; + jc = i__; + } + // + // Apply H or H**T + // + dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ + + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + jc * + c_dim1], ldc, &work[1], &ldwork); +// L10: + } + } + work[1] = (double) lwkopt; + return 0; + // + // End of DORMLQ + // +} // dormlq_ + diff --git a/3rdparty/clapack/src/disnan.c b/3rdparty/clapack/src/disnan.c new file mode 100644 index 0000000000..bebef51499 --- /dev/null +++ b/3rdparty/clapack/src/disnan.c @@ -0,0 +1,186 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DISNAN tests input for NaN. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DISNAN + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// LOGICAL FUNCTION DISNAN( DIN ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION, INTENT(IN) :: DIN +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. +//> otherwise. To be replaced by the Fortran 2003 intrinsic in the +//> future. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] DIN +//> \verbatim +//> DIN is DOUBLE PRECISION +//> Input to test for NaN. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +int disnan_(double *din) +{ + // System generated locals + int ret_val; + + // Local variables + extern int dlaisnan_(double *, double *); + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. External Functions .. + // .. + // .. Executable Statements .. + ret_val = dlaisnan_(din, din); + return ret_val; +} // disnan_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAISNAN + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] DIN1 +//> \verbatim +//> DIN1 is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] DIN2 +//> \verbatim +//> DIN2 is DOUBLE PRECISION +//> Two numbers to compare for inequality. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +int dlaisnan_(double *din1, double *din2) +{ + // System generated locals + int ret_val; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. Executable Statements .. + ret_val = *din1 != *din2; + return ret_val; +} // dlaisnan_ + diff --git a/3rdparty/clapack/src/dlacpy.c b/3rdparty/clapack/src/dlacpy.c new file mode 100644 index 0000000000..98278a32f3 --- /dev/null +++ b/3rdparty/clapack/src/dlacpy.c @@ -0,0 +1,184 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLACPY copies all or part of one two-dimensional array to another. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLACPY + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) +// +// .. Scalar Arguments .. +// CHARACTER UPLO +// INTEGER LDA, LDB, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLACPY copies all or part of a two-dimensional matrix A to another +//> matrix B. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] UPLO +//> \verbatim +//> UPLO is 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 +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[out] B +//> \verbatim +//> B is DOUBLE PRECISION array, dimension (LDB,N) +//> On exit, B = A in the locations specified by UPLO. +//> \endverbatim +//> +//> \param[in] LDB +//> \verbatim +//> LDB is INTEGER +//> The leading dimension of the array B. LDB >= max(1,M). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlacpy_(char *uplo, int *m, int *n, double *a, int *lda, + double *b, int *ldb) +{ + // System generated locals + int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + // Local variables + int i__, j; + extern int lsame_(char *, char *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Parameter adjustments + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + // Function Body + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +// L10: + } +// L20: + } + } else if (lsame_(uplo, "L")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +// L30: + } +// L40: + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +// L50: + } +// L60: + } + } + return 0; + // + // End of DLACPY + // +} // dlacpy_ + diff --git a/3rdparty/clapack/src/dlange.c b/3rdparty/clapack/src/dlange.c new file mode 100644 index 0000000000..43a321a282 --- /dev/null +++ b/3rdparty/clapack/src/dlange.c @@ -0,0 +1,367 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DCOMBSSQ adds two scaled sum of squares quantities. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// +// Definition: +// =========== +// +// SUBROUTINE DCOMBSSQ( V1, V2 ) +// +// .. Array Arguments .. +// DOUBLE PRECISION V1( 2 ), V2( 2 ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DCOMBSSQ adds two scaled sum of squares quantities, V1 := V1 + V2. +//> That is, +//> +//> V1_scale**2 * V1_sumsq := V1_scale**2 * V1_sumsq +//> + V2_scale**2 * V2_sumsq +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in,out] V1 +//> \verbatim +//> V1 is DOUBLE PRECISION array, dimension (2). +//> The first scaled sum. +//> V1(1) = V1_scale, V1(2) = V1_sumsq. +//> \endverbatim +//> +//> \param[in] V2 +//> \verbatim +//> V2 is DOUBLE PRECISION array, dimension (2). +//> The second scaled sum. +//> V2(1) = V2_scale, V2(2) = V2_sumsq. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2018 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dcombssq_(double *v1, double *v2) +{ + // System generated locals + double d__1; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2018 + // + // .. Array Arguments .. + // .. + // + //===================================================================== + // + // .. Parameters .. + // .. + // .. Executable Statements .. + // + // Parameter adjustments + --v2; + --v1; + + // Function Body + if (v1[1] >= v2[1]) { + if (v1[1] != 0.) { + // Computing 2nd power + d__1 = v2[1] / v1[1]; + v1[2] += d__1 * d__1 * v2[2]; + } + } else { + // Computing 2nd power + d__1 = v1[1] / v2[1]; + v1[2] = v2[2] + d__1 * d__1 * v1[2]; + v1[1] = v2[1]; + } + return 0; + // + // End of DCOMBSSQ + // +} // dcombssq_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLANGE + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) +// +// .. Scalar Arguments .. +// CHARACTER NORM +// INTEGER LDA, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +//> \return DLANGE +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] NORM +//> \verbatim +//> NORM is CHARACTER*1 +//> Specifies the value to be returned in DLANGE as described +//> above. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. M >= 0. When M = 0, +//> DLANGE is set to zero. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. N >= 0. When N = 0, +//> DLANGE is set to zero. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> The m by n matrix A. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(M,1). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +//> where LWORK >= M when NORM = 'I'; otherwise, WORK is not +//> referenced. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleGEauxiliary +// +// ===================================================================== +double dlange_(char *norm, int *m, int *n, double *a, int *lda, double *work) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int a_dim1, a_offset, i__1, i__2; + double ret_val, d__1; + + // Local variables + extern /* Subroutine */ int dcombssq_(double *, double *); + int i__, j; + double sum, ssq[2], temp; + extern int lsame_(char *, char *); + double value; + extern int disnan_(double *); + extern /* Subroutine */ int dlassq_(int *, double *, int *, double *, + double *); + double colssq[2]; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + //===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. Local Arrays .. + // .. + // .. 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__) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } +// 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: + } + if (value < sum || disnan_(&sum)) { + 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__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } +// L80: + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + // + // Find normF(A). + // SSQ(1) is scale + // SSQ(2) is sum-of-squares + // For better accuracy, sum each column separately. + // + ssq[0] = 0.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + dlassq_(m, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +// L90: + } + value = ssq[0] * sqrt(ssq[1]); + } + ret_val = value; + return ret_val; + // + // End of DLANGE + // +} // dlange_ + diff --git a/3rdparty/clapack/src/dlapy2.c b/3rdparty/clapack/src/dlapy2.c new file mode 100644 index 0000000000..01b8cae9f5 --- /dev/null +++ b/3rdparty/clapack/src/dlapy2.c @@ -0,0 +1,125 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLAPY2 returns sqrt(x2+y2). +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLAPY2 + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION X, Y +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +//> overflow. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] X +//> \verbatim +//> X is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] Y +//> \verbatim +//> Y is DOUBLE PRECISION +//> X and Y specify the values x and y. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +double dlapy2_(double *x, double *y) +{ + // System generated locals + double ret_val, d__1; + + // Local variables + int x_is_nan__, y_is_nan__; + double w, z__, xabs, yabs; + extern int disnan_(double *); + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + x_is_nan__ = disnan_(x); + y_is_nan__ = disnan_(y); + if (x_is_nan__) { + ret_val = *x; + } + if (y_is_nan__) { + ret_val = *y; + } + if (! (x_is_nan__ || y_is_nan__)) { + xabs = abs(*x); + yabs = abs(*y); + w = max(xabs,yabs); + z__ = min(xabs,yabs); + if (z__ == 0.) { + ret_val = w; + } else { + // Computing 2nd power + d__1 = z__ / w; + ret_val = w * sqrt(d__1 * d__1 + 1.); + } + } + return ret_val; + // + // End of DLAPY2 + // +} // dlapy2_ + diff --git a/3rdparty/clapack/src/dlarf.c b/3rdparty/clapack/src/dlarf.c new file mode 100644 index 0000000000..d74b12d549 --- /dev/null +++ b/3rdparty/clapack/src/dlarf.c @@ -0,0 +1,768 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DGER +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION ALPHA +// INTEGER INCX,INCY,LDA,M,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A(LDA,*),X(*),Y(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DGER performs the rank 1 operation +//> +//> A := alpha*x*y**T + 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> On entry, M specifies the number of rows of the matrix A. +//> M must be at least zero. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> On entry, N specifies the number of columns of the matrix A. +//> N must be at least zero. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION. +//> On entry, ALPHA specifies the scalar alpha. +//> \endverbatim +//> +//> \param[in] X +//> \verbatim +//> X is DOUBLE PRECISION array, dimension at least +//> ( 1 + ( m - 1 )*abs( INCX ) ). +//> Before entry, the incremented array X must contain the m +//> element vector x. +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> On entry, INCX specifies the increment for the elements of +//> X. INCX must not be zero. +//> \endverbatim +//> +//> \param[in] Y +//> \verbatim +//> Y is DOUBLE PRECISION array, dimension at least +//> ( 1 + ( n - 1 )*abs( INCY ) ). +//> Before entry, the incremented array Y must contain the n +//> element vector y. +//> \endverbatim +//> +//> \param[in] INCY +//> \verbatim +//> INCY is INTEGER +//> On entry, INCY specifies the increment for the elements of +//> Y. INCY must not be zero. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is 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 ). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup double_blas_level2 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dger_(int *m, int *n, double *alpha, double *x, int * + incx, double *y, int *incy, double *a, int *lda) +{ + // System generated locals + int a_dim1, a_offset, i__1, i__2; + + // Local variables + int i__, j, ix, jy, kx, info; + double temp; + extern /* Subroutine */ int xerbla_(char *, int *); + + // + // -- Reference BLAS level2 routine (version 3.7.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. 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 (*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; + } + // + // Quick return if possible. + // + if (*m == 0 || *n == 0 || *alpha == 0.) { + return 0; + } + // + // Start the operations. In this version the elements of A are + // accessed sequentially with one pass through A. + // + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +// L10: + } + } + jy += *incy; +// L20: + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +// L30: + } + } + jy += *incy; +// L40: + } + } + return 0; + // + // End of DGER . + // +} // dger_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DLARF applies an elementary reflector to a general rectangular matrix. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLARF + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +// +// .. Scalar Arguments .. +// CHARACTER SIDE +// INTEGER INCV, LDC, M, N +// DOUBLE PRECISION TAU +// .. +// .. Array Arguments .. +// DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T +//> +//> where tau is a real scalar and v is a real vector. +//> +//> If tau = 0, then H is taken to be the unit matrix. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'L': form H * C +//> = 'R': form C * H +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. +//> \endverbatim +//> +//> \param[in] V +//> \verbatim +//> V is 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. +//> \endverbatim +//> +//> \param[in] INCV +//> \verbatim +//> INCV is INTEGER +//> The increment between elements of v. INCV <> 0. +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION +//> The value tau in the representation of H. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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'. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= max(1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension +//> (N) if SIDE = 'L' +//> or (M) if SIDE = 'R' +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlarf_(char *side, int *m, int *n, double *v, int *incv, + double *tau, double *c__, int *ldc, double *work) +{ + // Table of constant values + double c_b4 = 1.; + double c_b5 = 0.; + int c__1 = 1; + + // System generated locals + int c_dim1, c_offset; + double d__1; + + // Local variables + int i__; + int applyleft; + extern /* Subroutine */ int dger_(int *, int *, double *, double *, int *, + double *, int *, double *, int *); + extern int lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, int *, int *, double *, double + *, int *, double *, int *, double *, double *, int *); + int lastc, lastv; + extern int iladlc_(int *, int *, double *, int *), iladlr_(int *, int *, + double *, int *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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)**T * 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)**T + // + 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)**T + // + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b ILADLC scans a matrix for its last non-zero column. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download ILADLC + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// INTEGER FUNCTION ILADLC( M, N, A, LDA ) +// +// .. Scalar Arguments .. +// INTEGER M, N, LDA +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> ILADLC scans A for its last non-zero column. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> The m by n matrix A. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +int iladlc_(int *m, int *n, double *a, int *lda) +{ + // System generated locals + int a_dim1, a_offset, ret_val, i__1; + + // Local variables + int i__; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b ILADLR scans a matrix for its last non-zero row. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download ILADLR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// INTEGER FUNCTION ILADLR( M, N, A, LDA ) +// +// .. Scalar Arguments .. +// INTEGER M, N, LDA +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> ILADLR scans A for its last non-zero row. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> The m by n matrix A. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +int iladlr_(int *m, int *n, double *a, int *lda) +{ + // System generated locals + int a_dim1, a_offset, ret_val, i__1; + + // Local variables + int i__, j; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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) { + i__ = *m; + while(a[max(i__,1) + j * a_dim1] == 0. && i__ >= 1) { + --i__; + } + ret_val = max(ret_val,i__); + } + } + return ret_val; +} // iladlr_ + diff --git a/3rdparty/clapack/src/dlarfb.c b/3rdparty/clapack/src/dlarfb.c new file mode 100644 index 0000000000..ea02d9c5c8 --- /dev/null +++ b/3rdparty/clapack/src/dlarfb.c @@ -0,0 +1,824 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLARFB + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, +// T, LDT, C, LDC, WORK, LDWORK ) +// +// .. Scalar Arguments .. +// CHARACTER DIRECT, SIDE, STOREV, TRANS +// INTEGER K, LDC, LDT, LDV, LDWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), +// $ WORK( LDWORK, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLARFB applies a real block reflector H or its transpose H**T to a +//> real m by n matrix C, from either the left or the right. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'L': apply H or H**T from the Left +//> = 'R': apply H or H**T from the Right +//> \endverbatim +//> +//> \param[in] TRANS +//> \verbatim +//> TRANS is CHARACTER*1 +//> = 'N': apply H (No transpose) +//> = 'T': apply H**T (Transpose) +//> \endverbatim +//> +//> \param[in] DIRECT +//> \verbatim +//> DIRECT is 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) +//> \endverbatim +//> +//> \param[in] STOREV +//> \verbatim +//> STOREV is CHARACTER*1 +//> Indicates how the vectors which define the elementary +//> reflectors are stored: +//> = 'C': Columnwise +//> = 'R': Rowwise +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The order of the matrix T (= the number of elementary +//> reflectors whose product defines the block reflector). +//> If SIDE = 'L', M >= K >= 0; +//> if SIDE = 'R', N >= K >= 0. +//> \endverbatim +//> +//> \param[in] V +//> \verbatim +//> V is 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. +//> \endverbatim +//> +//> \param[in] LDV +//> \verbatim +//> LDV is 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. +//> \endverbatim +//> +//> \param[in] T +//> \verbatim +//> T is DOUBLE PRECISION array, dimension (LDT,K) +//> The triangular k by k matrix T in the representation of the +//> block reflector. +//> \endverbatim +//> +//> \param[in] LDT +//> \verbatim +//> LDT is INTEGER +//> The leading dimension of the array T. LDT >= K. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is DOUBLE PRECISION array, dimension (LDC,N) +//> On entry, the m by n matrix C. +//> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= max(1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) +//> \endverbatim +//> +//> \param[in] LDWORK +//> \verbatim +//> LDWORK is INTEGER +//> The leading dimension of the array WORK. +//> If SIDE = 'L', LDWORK >= max(1,N); +//> if SIDE = 'R', LDWORK >= max(1,M). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2013 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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 ) +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char * + storev, int *m, int *n, int *k, double *v, int *ldv, double *t, int * + ldt, double *c__, int *ldc, double *work, int *ldwork) +{ + // Table of constant values + int c__1 = 1; + double c_b14 = 1.; + double c_b25 = -1.; + + // System generated locals + int c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2; + + // Local variables + int i__, j; + extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *, + double *, double *, int *, double *, int *, double *, double *, + int *); + extern int lsame_(char *, char *); + extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int * + ), dtrmm_(char *, char *, char *, char *, int *, int *, double *, + double *, int *, double *, int *); + char transt[1+1]={'\0'}; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2013 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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**T * C where C = ( C1 ) + // ( C2 ) + // + // W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) + // + // W := C1**T + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); +// L10: + } + // + // W := W * V1 + // + dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork); + if (*m > *k) { + // + // W := W + C2**T * V2 + // + i__1 = *m - *k; + dgemm_("Transpose", "No transpose", n, 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**T or W * T + // + dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + // + // C := C - V * W**T + // + if (*m > *k) { + // + // C2 := C2 - V2 * W**T + // + i__1 = *m - *k; + dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, & + v[*k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc); + } + // + // W := W * V1**T + // + dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork); + // + // C1 := C1 - W**T + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + 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**T where C = ( C1 C2 ) + // + // W := C * V = (C1*V1 + C2*V2) (stored in WORK) + // + // W := C1 + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); +// L40: + } + // + // W := W * V1 + // + dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork); + if (*n > *k) { + // + // W := W + C2 * V2 + // + i__1 = *n - *k; + dgemm_("No transpose", "No transpose", m, 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**T + // + dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + // + // C := C - W * V**T + // + if (*n > *k) { + // + // C2 := C2 - W * V2**T + // + i__1 = *n - *k; + dgemm_("No transpose", "Transpose", m, &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**T + // + dtrmm_("Right", "Lower", "Transpose", "Unit", m, 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 = *m; + 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**T * C where C = ( C1 ) + // ( C2 ) + // + // W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) + // + // W := C2**T + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); +// L70: + } + // + // W := W * V2 + // + dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + if (*m > *k) { + // + // W := W + C1**T * V1 + // + i__1 = *m - *k; + dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, & + c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork); + } + // + // W := W * T**T or W * T + // + dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + // + // C := C - V * W**T + // + if (*m > *k) { + // + // C1 := C1 - V1 * W**T + // + i__1 = *m - *k; + dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, & + v[v_offset], ldv, &work[work_offset], ldwork, & + c_b14, &c__[c_offset], ldc); + } + // + // W := W * V2**T + // + dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, & + v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + // + // C2 := C2 - W**T + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * + work_dim1]; +// L80: + } +// L90: + } + } else if (lsame_(side, "R")) { + // + // Form C * H or C * H**T where C = ( C1 C2 ) + // + // W := C * V = (C1*V1 + C2*V2) (stored in WORK) + // + // W := C2 + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &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", m, k, &c_b14, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + if (*n > *k) { + // + // W := W + C1 * V1 + // + i__1 = *n - *k; + dgemm_("No transpose", "No transpose", m, 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**T + // + dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + // + // C := C - W * V**T + // + if (*n > *k) { + // + // C1 := C1 - W * V1**T + // + i__1 = *n - *k; + dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, & + work[work_offset], ldwork, &v[v_offset], ldv, & + c_b14, &c__[c_offset], ldc); + } + // + // W := W * V2**T + // + dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, & + v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + // + // C2 := C2 - W + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (*n - *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**T * C where C = ( C1 ) + // ( C2 ) + // + // W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) + // + // W := C1**T + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); +// L130: + } + // + // W := W * V1**T + // + dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork); + if (*m > *k) { + // + // W := W + C2**T * V2**T + // + i__1 = *m - *k; + dgemm_("Transpose", "Transpose", n, 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**T or W * T + // + dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + // + // C := C - V**T * W**T + // + if (*m > *k) { + // + // C2 := C2 - V2**T * W**T + // + i__1 = *m - *k; + dgemm_("Transpose", "Transpose", &i__1, n, 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", n, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork); + // + // C1 := C1 - W**T + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + 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**T where C = ( C1 C2 ) + // + // W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) + // + // W := C1 + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); +// L160: + } + // + // W := W * V1**T + // + dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork); + if (*n > *k) { + // + // W := W + C2 * V2**T + // + i__1 = *n - *k; + dgemm_("No transpose", "Transpose", m, 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**T + // + dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + // + // C := C - W * V + // + if (*n > *k) { + // + // C2 := C2 - W * V2 + // + i__1 = *n - *k; + dgemm_("No transpose", "No transpose", m, &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", m, 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 = *m; + 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**T * C where C = ( C1 ) + // ( C2 ) + // + // W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) + // + // W := C2**T + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); +// L190: + } + // + // W := W * V2**T + // + dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, & + v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] + , ldwork); + if (*m > *k) { + // + // W := W + C1**T * V1**T + // + i__1 = *m - *k; + dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, & + c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork); + } + // + // W := W * T**T or W * T + // + dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + // + // C := C - V**T * W**T + // + if (*m > *k) { + // + // C1 := C1 - V1**T * W**T + // + i__1 = *m - *k; + dgemm_("Transpose", "Transpose", &i__1, n, 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", n, k, &c_b14, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + // + // C2 := C2 - W**T + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[*m - *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 ) + // + // W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) + // + // W := C2 + // + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); +// L220: + } + // + // W := W * V2**T + // + dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, & + v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] + , ldwork); + if (*n > *k) { + // + // W := W + C1 * V1**T + // + i__1 = *n - *k; + dgemm_("No transpose", "Transpose", m, 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**T + // + dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + // + // C := C - W * V + // + if (*n > *k) { + // + // C1 := C1 - W * V1 + // + i__1 = *n - *k; + dgemm_("No transpose", "No transpose", m, &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", m, k, &c_b14, + &v[(*n - *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 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * + work_dim1]; +// L230: + } +// L240: + } + } + } + } + return 0; + // + // End of DLARFB + // +} // dlarfb_ + diff --git a/3rdparty/clapack/src/dlarfg.c b/3rdparty/clapack/src/dlarfg.c new file mode 100644 index 0000000000..b14eb412de --- /dev/null +++ b/3rdparty/clapack/src/dlarfg.c @@ -0,0 +1,216 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLARFG generates an elementary reflector (Householder matrix). +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLARFG + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +// +// .. Scalar Arguments .. +// INTEGER INCX, N +// DOUBLE PRECISION ALPHA, TAU +// .. +// .. Array Arguments .. +// DOUBLE PRECISION X( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLARFG generates a real elementary reflector H of order n, such +//> that +//> +//> H * ( alpha ) = ( beta ), H**T * 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**T ) , +//> ( 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the elementary reflector. +//> \endverbatim +//> +//> \param[in,out] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION +//> On entry, the value alpha. +//> On exit, it is overwritten with the value beta. +//> \endverbatim +//> +//> \param[in,out] X +//> \verbatim +//> X is DOUBLE PRECISION array, dimension +//> (1+(N-2)*abs(INCX)) +//> On entry, the vector x. +//> On exit, it is overwritten with the vector v. +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> The increment between elements of X. INCX > 0. +//> \endverbatim +//> +//> \param[out] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION +//> The value tau. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup doubleOTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlarfg_(int *n, double *alpha, double *x, int *incx, + double *tau) +{ + // System generated locals + int i__1; + double d__1; + + // Local variables + int j, knt; + double beta; + extern double dnrm2_(int *, double *, int *); + extern /* Subroutine */ int dscal_(int *, double *, double *, int *); + double xnorm; + extern double dlapy2_(double *, double *), dlamch_(char *); + double safmin, rsafmn; + + // + // -- LAPACK auxiliary routine (version 3.8.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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 && knt < 20) { + goto L10; + } + // + // New BETA is at most 1, at least SAFMIN + // + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_sign(&d__1, alpha); + } + *tau = (beta - *alpha) / beta; + i__1 = *n - 1; + d__1 = 1. / (*alpha - beta); + dscal_(&i__1, &d__1, &x[1], incx); + // + // If ALPHA is subnormal, it may lose relative accuracy + // + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; +// L20: + } + *alpha = beta; + } + return 0; + // + // End of DLARFG + // +} // dlarfg_ + diff --git a/3rdparty/clapack/src/dlarft.c b/3rdparty/clapack/src/dlarft.c new file mode 100644 index 0000000000..a697873c24 --- /dev/null +++ b/3rdparty/clapack/src/dlarft.c @@ -0,0 +1,389 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLARFT + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +// +// .. Scalar Arguments .. +// CHARACTER DIRECT, STOREV +// INTEGER K, LDT, LDV, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T +//> +//> 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 * T * V +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] DIRECT +//> \verbatim +//> DIRECT is 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) +//> \endverbatim +//> +//> \param[in] STOREV +//> \verbatim +//> STOREV is CHARACTER*1 +//> Specifies how the vectors which define the elementary +//> reflectors are stored (see also Further Details): +//> = 'C': columnwise +//> = 'R': rowwise +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The order of the block reflector H. N >= 0. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The order of the triangular factor T (= the number of +//> elementary reflectors). K >= 1. +//> \endverbatim +//> +//> \param[in] V +//> \verbatim +//> V is DOUBLE PRECISION array, dimension +//> (LDV,K) if STOREV = 'C' +//> (LDV,N) if STOREV = 'R' +//> The matrix V. See further details. +//> \endverbatim +//> +//> \param[in] LDV +//> \verbatim +//> LDV is INTEGER +//> The leading dimension of the array V. +//> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i). +//> \endverbatim +//> +//> \param[out] T +//> \verbatim +//> T is 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. +//> \endverbatim +//> +//> \param[in] LDT +//> \verbatim +//> LDT is INTEGER +//> The leading dimension of the array T. LDT >= K. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> +//> 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 ) +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dlarft_(char *direct, char *storev, int *n, int *k, + double *v, int *ldv, double *tau, double *t, int *ldt) +{ + // Table of constant values + int c__1 = 1; + double c_b7 = 1.; + + // System generated locals + int t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; + double d__1; + + // Local variables + int i__, j, prevlastv; + extern int lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, int *, int *, double *, double + *, int *, double *, int *, double *, double *, int *); + int lastv; + extern /* Subroutine */ int dtrmv_(char *, char *, char *, int *, double * + , int *, double *, int *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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.; + } + } else { + // + // general case + // + 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; + } + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1]; + } + j = min(lastv,prevlastv); + // + // T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) + // + i__2 = j - i__; + i__3 = i__ - 1; + d__1 = -tau[i__]; + dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 + + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, & + c_b7, &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; + } + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; + } + j = min(lastv,prevlastv); + // + // T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T + // + i__2 = i__ - 1; + i__3 = j - i__; + d__1 = -tau[i__]; + dgemv_("No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * + v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], + ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1); + } + // + // 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; + } + } + } + } 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.; + } + } else { + // + // general case + // + if (i__ < *k) { + if (lsame_(storev, "C")) { + // Skip any leading zeros. + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + break; + } + } + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ + + j * v_dim1]; + } + j = max(lastv,prevlastv); + // + // T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) + // + i__1 = *n - *k + i__ - j; + 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_b7, &t[i__ + 1 + i__ * t_dim1], & + c__1); + } else { + // Skip any leading zeros. + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + break; + } + } + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k + + i__) * v_dim1]; + } + 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)**T + // + i__1 = *k - i__; + i__2 = *n - *k + i__ - j; + 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_b7, &t[i__ + 1 + i__ * t_dim1], &c__1) + ; + } + // + // 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__]; + } + } + } + return 0; + // + // End of DLARFT + // +} // dlarft_ + diff --git a/3rdparty/clapack/src/dlartg.c b/3rdparty/clapack/src/dlartg.c new file mode 100644 index 0000000000..6ec26c7c81 --- /dev/null +++ b/3rdparty/clapack/src/dlartg.c @@ -0,0 +1,236 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLARTG generates a plane rotation with real cosine and real sine. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLARTG + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLARTG( F, G, CS, SN, R ) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION CS, F, G, R, SN +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] F +//> \verbatim +//> F is DOUBLE PRECISION +//> The first component of vector to be rotated. +//> \endverbatim +//> +//> \param[in] G +//> \verbatim +//> G is DOUBLE PRECISION +//> The second component of vector to be rotated. +//> \endverbatim +//> +//> \param[out] CS +//> \verbatim +//> CS is DOUBLE PRECISION +//> The cosine of the rotation. +//> \endverbatim +//> +//> \param[out] SN +//> \verbatim +//> SN is DOUBLE PRECISION +//> The sine of the rotation. +//> \endverbatim +//> +//> \param[out] R +//> \verbatim +//> R is 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. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlartg_(double *f, double *g, double *cs, double *sn, + double *r__) +{ + // System generated locals + int i__1; + double d__1, d__2; + + // Local variables + int i__; + double f1, g1, eps, scale; + int count; + double safmn2, safmx2; + extern double dlamch_(char *); + double safmin; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. 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 ) THEN + safmin = dlamch_("S"); + eps = dlamch_("E"); + d__1 = dlamch_("B"); + i__1 = (int) (log(safmin / eps) / log(dlamch_("B")) / 2.); + safmn2 = pow_di(&d__1, &i__1); + safmx2 = 1. / safmn2; + // FIRST = .FALSE. + // END IF + if (*g == 0.) { + *cs = 1.; + *sn = 0.; + *r__ = *f; + } else if (*f == 0.) { + *cs = 0.; + *sn = 1.; + *r__ = *g; + } else { + f1 = *f; + g1 = *g; + // Computing MAX + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1,d__2); + if (scale >= safmx2) { + count = 0; +L10: + ++count; + f1 *= safmn2; + g1 *= safmn2; + // Computing MAX + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1,d__2); + if (scale >= safmx2) { + goto L10; + } + // Computing 2nd power + d__1 = f1; + // Computing 2nd power + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmx2; +// L20: + } + } else if (scale <= safmn2) { + count = 0; +L30: + ++count; + f1 *= safmx2; + g1 *= safmx2; + // Computing MAX + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1,d__2); + if (scale <= safmn2) { + goto L30; + } + // Computing 2nd power + d__1 = f1; + // Computing 2nd power + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmn2; +// L40: + } + } else { + // Computing 2nd power + d__1 = f1; + // Computing 2nd power + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + } + if (abs(*f) > abs(*g) && *cs < 0.) { + *cs = -(*cs); + *sn = -(*sn); + *r__ = -(*r__); + } + } + return 0; + // + // End of DLARTG + // +} // dlartg_ + diff --git a/3rdparty/clapack/src/dlascl.c b/3rdparty/clapack/src/dlascl.c new file mode 100644 index 0000000000..7a1f9f2bfd --- /dev/null +++ b/3rdparty/clapack/src/dlascl.c @@ -0,0 +1,413 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASCL + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER TYPE +// INTEGER INFO, KL, KU, LDA, M, N +// DOUBLE PRECISION CFROM, CTO +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] TYPE +//> \verbatim +//> TYPE is 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. See DGBTRF for storage details. +//> \endverbatim +//> +//> \param[in] KL +//> \verbatim +//> KL is INTEGER +//> The lower bandwidth of A. Referenced only if TYPE = 'B', +//> 'Q' or 'Z'. +//> \endverbatim +//> +//> \param[in] KU +//> \verbatim +//> KU is INTEGER +//> The upper bandwidth of A. Referenced only if TYPE = 'B', +//> 'Q' or 'Z'. +//> \endverbatim +//> +//> \param[in] CFROM +//> \verbatim +//> CFROM is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] CTO +//> \verbatim +//> CTO is 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. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is DOUBLE PRECISION array, dimension (LDA,N) +//> The matrix to be multiplied by CTO/CFROM. See TYPE for the +//> storage type. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. +//> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +//> TYPE = 'B', LDA >= KL+1; +//> TYPE = 'Q', LDA >= KU+1; +//> TYPE = 'Z', LDA >= 2*KL+KU+1. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> 0 - successful exit +//> <0 - if INFO = -i, the i-th argument had an illegal value. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlascl_(char *type__, int *kl, int *ku, double *cfrom, + double *cto, int *m, int *n, double *a, int *lda, int *info) +{ + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + // Local variables + int i__, j, k1, k2, k3, k4; + double mul, cto1; + int done; + double ctoc; + extern int lsame_(char *, char *); + int itype; + double cfrom1; + extern double dlamch_(char *); + double cfromc; + extern int disnan_(double *); + extern /* Subroutine */ int xerbla_(char *, int *); + double bignum, smlnum; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Intrinsic Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Executable Statements .. + // + // Test the input arguments + // + // Parameter adjustments + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + // Function Body + *info = 0; + if (lsame_(type__, "G")) { + itype = 0; + } else if (lsame_(type__, "L")) { + itype = 1; + } else if (lsame_(type__, "U")) { + itype = 2; + } else if (lsame_(type__, "H")) { + itype = 3; + } else if (lsame_(type__, "B")) { + itype = 4; + } else if (lsame_(type__, "Q")) { + itype = 5; + } else if (lsame_(type__, "Z")) { + itype = 6; + } else { + itype = -1; + } + if (itype == -1) { + *info = -1; + } else if (*cfrom == 0. || disnan_(cfrom)) { + *info = -4; + } else if (disnan_(cto)) { + *info = -5; + } else if (*m < 0) { + *info = -6; + } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { + *info = -7; + } else if (itype <= 3 && *lda < max(1,*m)) { + *info = -9; + } else if (itype >= 4) { + // Computing MAX + i__1 = *m - 1; + if (*kl < 0 || *kl > max(i__1,0)) { + *info = -2; + } else /* if(complicated condition) */ { + // Computing MAX + i__1 = *n - 1; + if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && + *kl != *ku) { + *info = -3; + } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * + ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { + *info = -9; + } + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASCL", &i__1); + return 0; + } + // + // Quick return if possible + // + if (*n == 0 || *m == 0) { + return 0; + } + // + // Get machine parameters + // + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + cfromc = *cfrom; + ctoc = *cto; +L10: + cfrom1 = cfromc * smlnum; + if (cfrom1 == cfromc) { + // CFROMC is an inf. Multiply by a correctly signed zero for + // finite CTOC, or a NaN if CTOC is infinite. + mul = ctoc / cfromc; + done = TRUE_; + cto1 = ctoc; + } else { + cto1 = ctoc / bignum; + if (cto1 == ctoc) { + // CTOC is either 0 or an inf. In both cases, CTOC itself + // serves as the correct multiplication factor. + mul = ctoc; + done = TRUE_; + cfromc = 1.; + } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { + mul = smlnum; + done = FALSE_; + cfromc = cfrom1; + } else if (abs(cto1) > abs(cfromc)) { + mul = bignum; + done = FALSE_; + ctoc = cto1; + } else { + mul = ctoc / cfromc; + done = TRUE_; + } + } + if (itype == 0) { + // + // Full matrix + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +// L20: + } +// L30: + } + } else if (itype == 1) { + // + // Lower triangular matrix + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +// L40: + } +// L50: + } + } else if (itype == 2) { + // + // Upper triangular matrix + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +// L60: + } +// L70: + } + } else if (itype == 3) { + // + // Upper Hessenberg matrix + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + // Computing MIN + i__3 = j + 1; + i__2 = min(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +// L80: + } +// L90: + } + } else if (itype == 4) { + // + // Lower half of a symmetric band matrix + // + k3 = *kl + 1; + k4 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + // Computing MIN + i__3 = k3, i__4 = k4 - j; + i__2 = min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +// L100: + } +// L110: + } + } else if (itype == 5) { + // + // Upper half of a symmetric band matrix + // + k1 = *ku + 2; + k3 = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + // Computing MAX + i__2 = k1 - j; + i__3 = k3; + for (i__ = max(i__2,1); i__ <= i__3; ++i__) { + a[i__ + j * a_dim1] *= mul; +// L120: + } +// L130: + } + } else if (itype == 6) { + // + // Band matrix + // + k1 = *kl + *ku + 2; + k2 = *kl + 1; + k3 = (*kl << 1) + *ku + 1; + k4 = *kl + *ku + 1 + *m; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + // Computing MAX + i__3 = k1 - j; + // Computing MIN + i__4 = k3, i__5 = k4 - j; + i__2 = min(i__4,i__5); + for (i__ = max(i__3,k2); i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +// L140: + } +// L150: + } + } + if (! done) { + goto L10; + } + return 0; + // + // End of DLASCL + // +} // dlascl_ + diff --git a/3rdparty/clapack/src/dlaset.c b/3rdparty/clapack/src/dlaset.c new file mode 100644 index 0000000000..ec2baadbdd --- /dev/null +++ b/3rdparty/clapack/src/dlaset.c @@ -0,0 +1,209 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASET + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +// +// .. Scalar Arguments .. +// CHARACTER UPLO +// INTEGER LDA, M, N +// DOUBLE PRECISION ALPHA, BETA +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DLASET initializes an m-by-n matrix A to BETA on the diagonal and +//> ALPHA on the offdiagonals. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] UPLO +//> \verbatim +//> UPLO is 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. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix A. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix A. N >= 0. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is DOUBLE PRECISION +//> The constant to which the offdiagonal elements are to be set. +//> \endverbatim +//> +//> \param[in] BETA +//> \verbatim +//> BETA is DOUBLE PRECISION +//> The constant to which the diagonal elements are to be set. +//> \endverbatim +//> +//> \param[out] A +//> \verbatim +//> A is 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). +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. LDA >= max(1,M). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlaset_(char *uplo, int *m, int *n, double *alpha, + double *beta, double *a, int *lda) +{ + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3; + + // Local variables + int i__, j; + extern int lsame_(char *, char *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + //===================================================================== + // + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Executable Statements .. + // + // Parameter adjustments + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + // Function Body + if (lsame_(uplo, "U")) { + // + // Set the strictly upper triangular or trapezoidal part of the + // array to ALPHA. + // + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + // Computing MIN + i__3 = j - 1; + i__2 = min(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +// L10: + } +// L20: + } + } else if (lsame_(uplo, "L")) { + // + // Set the strictly lower triangular or trapezoidal part of the + // array to ALPHA. + // + i__1 = min(*m,*n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +// L30: + } +// L40: + } + } else { + // + // Set the leading m-by-n submatrix to ALPHA. + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +// L50: + } +// L60: + } + } + // + // Set the first min(M,N) diagonal elements to BETA. + // + i__1 = min(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + i__ * a_dim1] = *beta; +// L70: + } + return 0; + // + // End of DLASET + // +} // dlaset_ + diff --git a/3rdparty/clapack/src/dlassq.c b/3rdparty/clapack/src/dlassq.c new file mode 100644 index 0000000000..ea3fb23e55 --- /dev/null +++ b/3rdparty/clapack/src/dlassq.c @@ -0,0 +1,172 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DLASSQ updates a sum of squares represented in scaled form. +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DLASSQ + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +// +// .. Scalar Arguments .. +// INTEGER INCX, N +// DOUBLE PRECISION SCALE, SUMSQ +// .. +// .. Array Arguments .. +// DOUBLE PRECISION X( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of elements to be used from the vector X. +//> \endverbatim +//> +//> \param[in] X +//> \verbatim +//> X is DOUBLE PRECISION array, dimension (1+(N-1)*INCX) +//> The vector for which a scaled sum of squares is computed. +//> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> The increment between successive values of the vector X. +//> INCX > 0. +//> \endverbatim +//> +//> \param[in,out] SCALE +//> \verbatim +//> SCALE is 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. +//> \endverbatim +//> +//> \param[in,out] SUMSQ +//> \verbatim +//> SUMSQ is 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. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +/* Subroutine */ int dlassq_(int *n, double *x, int *incx, double *scale, + double *sumsq) +{ + // System generated locals + int i__1, i__2; + double d__1; + + // Local variables + int ix; + double absxi; + extern int disnan_(double *); + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + //===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. External Functions .. + // .. + // .. 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) { + absxi = (d__1 = x[ix], abs(d__1)); + if (absxi > 0. || disnan_(&absxi)) { + if (*scale < absxi) { + // Computing 2nd power + d__1 = *scale / absxi; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = absxi; + } else { + // Computing 2nd power + d__1 = absxi / *scale; + *sumsq += d__1 * d__1; + } + } +// L10: + } + } + return 0; + // + // End of DLASSQ + // +} // dlassq_ + diff --git a/3rdparty/clapack/src/dnrm2.c b/3rdparty/clapack/src/dnrm2.c new file mode 100644 index 0000000000..688a6ffb57 --- /dev/null +++ b/3rdparty/clapack/src/dnrm2.c @@ -0,0 +1,149 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DNRM2 +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) +// +// .. Scalar Arguments .. +// INTEGER INCX,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION X(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DNRM2 returns the euclidean norm of a vector via the function +//> name, so that +//> +//> DNRM2 := sqrt( x'*x ) +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> number of elements in input vector(s) +//> \endverbatim +//> +//> \param[in] X +//> \verbatim +//> X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> storage spacing between elements of DX +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup double_blas_level1 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> -- This version written on 25-October-1982. +//> Modified on 14-October-1993 to inline the call to DLASSQ. +//> Sven Hammarling, Nag Ltd. +//> \endverbatim +//> +// ===================================================================== +double dnrm2_(int *n, double *x, int *incx) +{ + // System generated locals + int i__1, i__2; + double ret_val, d__1; + + // Local variables + int ix; + double ssq, norm, scale, absxi; + + // + // -- Reference BLAS level1 routine (version 3.8.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Parameters .. + // .. + // .. Local Scalars .. + // .. + // .. Intrinsic Functions .. + // .. + // Parameter adjustments + --x; + + // Function Body + if (*n < 1 || *incx < 1) { + norm = 0.; + } else if (*n == 1) { + norm = abs(x[1]); + } else { + scale = 0.; + ssq = 1.; + // The following loop is equivalent to this call to the LAPACK + // auxiliary routine: + // CALL DLASSQ( N, X, INCX, SCALE, SSQ ) + // + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + if (x[ix] != 0.) { + absxi = (d__1 = x[ix], abs(d__1)); + if (scale < absxi) { + // Computing 2nd power + d__1 = scale / absxi; + ssq = ssq * (d__1 * d__1) + 1.; + scale = absxi; + } else { + // Computing 2nd power + d__1 = absxi / scale; + ssq += d__1 * d__1; + } + } +// L10: + } + norm = scale * sqrt(ssq); + } + ret_val = norm; + return ret_val; + // + // End of DNRM2. + // +} // dnrm2_ + diff --git a/3rdparty/clapack/src/dorgqr.c b/3rdparty/clapack/src/dorgqr.c new file mode 100644 index 0000000000..b9fdc12654 --- /dev/null +++ b/3rdparty/clapack/src/dorgqr.c @@ -0,0 +1,571 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORG2R + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, K, LDA, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix Q. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix Q. M >= N >= 0. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of elementary reflectors whose product defines the +//> matrix Q. N >= K >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The first dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGEQRF. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (N) +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument has an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dorg2r_(int *m, int *n, int *k, double *a, int *lda, + double *tau, double *work, int *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int a_dim1, a_offset, i__1, i__2; + double d__1; + + // Local variables + int i__, j, l; + extern /* Subroutine */ int dscal_(int *, double *, double *, int *), + dlarf_(char *, int *, int *, double *, int *, double *, double *, + int *, double *), xerbla_(char *, int *); + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORGQR +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORGQR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// INTEGER INFO, K, LDA, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix Q. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix Q. M >= N >= 0. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of elementary reflectors whose product defines the +//> matrix Q. N >= K >= 0. +//> \endverbatim +//> +//> \param[in,out] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The first dimension of the array A. LDA >= max(1,M). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGEQRF. +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument has an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dorgqr_(int *m, int *n, int *k, double *a, int *lda, + double *tau, double *work, int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__3 = 3; + int c__2 = 2; + + // System generated locals + int a_dim1, a_offset, i__1, i__2, i__3; + + // Local variables + int i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; + extern /* Subroutine */ int dorg2r_(int *, int *, int *, double *, int *, + double *, double *, int *), dlarfb_(char *, char *, char *, char * + , int *, int *, int *, double *, int *, double *, int *, double *, + int *, double *, int *), dlarft_(char *, char *, int *, int *, + double *, int *, double *, double *, int *), xerbla_(char *, int * + ); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + int ldwork, lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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] = (double) 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] = (double) iws; + return 0; + // + // End of DORGQR + // +} // dorgqr_ + diff --git a/3rdparty/clapack/src/dormqr.c b/3rdparty/clapack/src/dormqr.c new file mode 100644 index 0000000000..c25a2cb4a2 --- /dev/null +++ b/3rdparty/clapack/src/dormqr.c @@ -0,0 +1,684 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORM2R + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +// WORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER SIDE, TRANS +// INTEGER INFO, K, LDA, LDC, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DORM2R overwrites the general real m by n matrix C with +//> +//> Q * C if SIDE = 'L' and TRANS = 'N', or +//> +//> Q**T* C if SIDE = 'L' and TRANS = 'T', or +//> +//> C * Q if SIDE = 'R' and TRANS = 'N', or +//> +//> C * Q**T 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'. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'L': apply Q or Q**T from the Left +//> = 'R': apply Q or Q**T from the Right +//> \endverbatim +//> +//> \param[in] TRANS +//> \verbatim +//> TRANS is CHARACTER*1 +//> = 'N': apply Q (No transpose) +//> = 'T': apply Q**T (Transpose) +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. N >= 0. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of elementary reflectors whose product defines +//> the matrix Q. +//> If SIDE = 'L', M >= K >= 0; +//> if SIDE = 'R', N >= K >= 0. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. +//> If SIDE = 'L', LDA >= max(1,M); +//> if SIDE = 'R', LDA >= max(1,N). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGEQRF. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= max(1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension +//> (N) if SIDE = 'L', +//> (M) if SIDE = 'R' +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dorm2r_(char *side, char *trans, int *m, int *n, int *k, + double *a, int *lda, double *tau, double *c__, int *ldc, double *work, + int *info) +{ + // Table of constant values + int c__1 = 1; + + // System generated locals + int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + + // Local variables + int i__, i1, i2, i3, ic, jc, mi, ni, nq; + double aii; + int left; + extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *, + double *, double *, int *, double *); + extern int lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, int *); + int notran; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b DORMQR +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download DORMQR + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +// WORK, LWORK, INFO ) +// +// .. Scalar Arguments .. +// CHARACTER SIDE, TRANS +// INTEGER INFO, K, LDA, LDC, LWORK, M, N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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'. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is CHARACTER*1 +//> = 'L': apply Q or Q**T from the Left; +//> = 'R': apply Q or Q**T from the Right. +//> \endverbatim +//> +//> \param[in] TRANS +//> \verbatim +//> TRANS is CHARACTER*1 +//> = 'N': No transpose, apply Q; +//> = 'T': Transpose, apply Q**T. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> The number of rows of the matrix C. M >= 0. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> The number of columns of the matrix C. N >= 0. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is INTEGER +//> The number of elementary reflectors whose product defines +//> the matrix Q. +//> If SIDE = 'L', M >= K >= 0; +//> if SIDE = 'R', N >= K >= 0. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is INTEGER +//> The leading dimension of the array A. +//> If SIDE = 'L', LDA >= max(1,M); +//> if SIDE = 'R', LDA >= max(1,N). +//> \endverbatim +//> +//> \param[in] TAU +//> \verbatim +//> TAU is DOUBLE PRECISION array, dimension (K) +//> TAU(i) must contain the scalar factor of the elementary +//> reflector H(i), as returned by DGEQRF. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is 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. +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is INTEGER +//> The leading dimension of the array C. LDC >= max(1,M). +//> \endverbatim +//> +//> \param[out] WORK +//> \verbatim +//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The dimension of the array WORK. +//> If SIDE = 'L', LWORK >= max(1,N); +//> if SIDE = 'R', LWORK >= max(1,M). +//> 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. +//> \endverbatim +//> +//> \param[out] INFO +//> \verbatim +//> INFO is INTEGER +//> = 0: successful exit +//> < 0: if INFO = -i, the i-th argument had an illegal value +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup doubleOTHERcomputational +// +// ===================================================================== +/* Subroutine */ int dormqr_(char *side, char *trans, int *m, int *n, int *k, + double *a, int *lda, double *tau, double *c__, int *ldc, double *work, + int *lwork, int *info) +{ + // Table of constant values + int c__1 = 1; + int c_n1 = -1; + int c__2 = 2; + int c__65 = 65; + + // System generated locals + address a__1[2]; + int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5; + char ch__1[2+1]={'\0'}; + + // Local variables + int i__, i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iwt; + int left; + extern int lsame_(char *, char *); + int nbmin, iinfo; + extern /* Subroutine */ int dorm2r_(char *, char *, int *, int *, int *, + double *, int *, double *, double *, int *, double *, int *), + dlarfb_(char *, char *, char *, char *, int *, int *, int *, + double *, int *, double *, int *, double *, int *, double *, int * + ), dlarft_(char *, char *, int *, int *, double *, int *, double * + , double *, int *), xerbla_(char *, int *); + extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); + int notran; + int ldwork, lwkopt; + int lquery; + + // + // -- LAPACK computational routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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"); + 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) { + // + // Compute the workspace requirements + // + // 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); + 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 + 4160; + work[1] = (double) 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) { + if (*lwork < nw * nb + 4160) { + nb = (*lwork - 4160) / 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); + i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1); + nbmin = max(i__1,i__2); + } + } + 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 + // + iwt = nw * nb + 1; + 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__], &work[iwt], &c__65); + if (left) { + // + // H or H**T is applied to C(i:m,1:n) + // + mi = *m - i__ + 1; + ic = i__; + } else { + // + // H or H**T is applied to C(1:m,i:n) + // + ni = *n - i__ + 1; + jc = i__; + } + // + // Apply H or H**T + // + dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ + i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic + + jc * c_dim1], ldc, &work[1], &ldwork); +// L10: + } + } + work[1] = (double) lwkopt; + return 0; + // + // End of DORMQR + // +} // dormqr_ + diff --git a/3rdparty/clapack/src/drot.c b/3rdparty/clapack/src/drot.c new file mode 100644 index 0000000000..b7c99f47ee --- /dev/null +++ b/3rdparty/clapack/src/drot.c @@ -0,0 +1,164 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DROT +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION C,S +// INTEGER INCX,INCY,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION DX(*),DY(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DROT applies a plane rotation. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> number of elements in input vector(s) +//> \endverbatim +//> +//> \param[in,out] DX +//> \verbatim +//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> storage spacing between elements of DX +//> \endverbatim +//> +//> \param[in,out] DY +//> \verbatim +//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +//> \endverbatim +//> +//> \param[in] INCY +//> \verbatim +//> INCY is INTEGER +//> storage spacing between elements of DY +//> \endverbatim +//> +//> \param[in] C +//> \verbatim +//> C is DOUBLE PRECISION +//> \endverbatim +//> +//> \param[in] S +//> \verbatim +//> S is DOUBLE PRECISION +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup double_blas_level1 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> jack dongarra, linpack, 3/11/78. +//> modified 12/3/93, array(1) declarations changed to array(*) +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int drot_(int *n, double *dx, int *incx, double *dy, int * + incy, double *c__, double *s) +{ + // System generated locals + int i__1; + + // Local variables + int i__, ix, iy; + double dtemp; + + // + // -- Reference BLAS level1 routine (version 3.8.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Local Scalars .. + // .. + // Parameter adjustments + --dy; + --dx; + + // Function Body + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + // + // code for both increments equal to 1 + // + 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; + } + } else { + // + // 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; + } + } + return 0; +} // drot_ + diff --git a/3rdparty/clapack/src/dscal.c b/3rdparty/clapack/src/dscal.c new file mode 100644 index 0000000000..e4f1d931b1 --- /dev/null +++ b/3rdparty/clapack/src/dscal.c @@ -0,0 +1,155 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DSCAL +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DSCAL(N,DA,DX,INCX) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION DA +// INTEGER INCX,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION DX(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DSCAL scales a vector by a constant. +//> uses unrolled loops for increment equal to 1. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> number of elements in input vector(s) +//> \endverbatim +//> +//> \param[in] DA +//> \verbatim +//> DA is DOUBLE PRECISION +//> On entry, DA specifies the scalar alpha. +//> \endverbatim +//> +//> \param[in,out] DX +//> \verbatim +//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> storage spacing between elements of DX +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup double_blas_level1 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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(*) +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dscal_(int *n, double *da, double *dx, int *incx) +{ + // System generated locals + int i__1, i__2; + + // Local variables + int i__, m, mp1, nincx; + + // + // -- Reference BLAS level1 routine (version 3.8.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Local Scalars .. + // .. + // .. Intrinsic Functions .. + // .. + // Parameter adjustments + --dx; + + // Function Body + if (*n <= 0 || *incx <= 0) { + return 0; + } + if (*incx == 1) { + // + // code for increment equal to 1 + // + // + // clean-up loop + // + m = *n % 5; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dx[i__] = *da * dx[i__]; + } + if (*n < 5) { + return 0; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; 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]; + } + } else { + // + // 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__]; + } + } + return 0; +} // dscal_ + diff --git a/3rdparty/clapack/src/dswap.c b/3rdparty/clapack/src/dswap.c new file mode 100644 index 0000000000..2510be8c6a --- /dev/null +++ b/3rdparty/clapack/src/dswap.c @@ -0,0 +1,178 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DSWAP +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +// +// .. Scalar Arguments .. +// INTEGER INCX,INCY,N +// .. +// .. Array Arguments .. +// DOUBLE PRECISION DX(*),DY(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DSWAP interchanges two vectors. +//> uses unrolled loops for increments equal to 1. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> number of elements in input vector(s) +//> \endverbatim +//> +//> \param[in,out] DX +//> \verbatim +//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> storage spacing between elements of DX +//> \endverbatim +//> +//> \param[in,out] DY +//> \verbatim +//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +//> \endverbatim +//> +//> \param[in] INCY +//> \verbatim +//> INCY is INTEGER +//> storage spacing between elements of DY +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2017 +// +//> \ingroup double_blas_level1 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> jack dongarra, linpack, 3/11/78. +//> modified 12/3/93, array(1) declarations changed to array(*) +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dswap_(int *n, double *dx, int *incx, double *dy, int * + incy) +{ + // System generated locals + int i__1; + + // Local variables + int i__, m, ix, iy, mp1; + double dtemp; + + // + // -- Reference BLAS level1 routine (version 3.8.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2017 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. Local Scalars .. + // .. + // .. Intrinsic Functions .. + // .. + // Parameter adjustments + --dy; + --dx; + + // Function Body + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + // + // code for both increments equal to 1 + // + // + // clean-up loop + // + m = *n % 3; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = dx[i__]; + dx[i__] = dy[i__]; + dy[i__] = dtemp; + } + if (*n < 3) { + return 0; + } + } + 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; + } + } else { + // + // 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; + } + } + return 0; +} // dswap_ + diff --git a/3rdparty/clapack/src/dtrmm.c b/3rdparty/clapack/src/dtrmm.c new file mode 100644 index 0000000000..43c1e77aa8 --- /dev/null +++ b/3rdparty/clapack/src/dtrmm.c @@ -0,0 +1,509 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DTRMM +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +// +// .. Scalar Arguments .. +// DOUBLE PRECISION ALPHA +// INTEGER LDA,LDB,M,N +// CHARACTER DIAG,SIDE,TRANSA,UPLO +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A(LDA,*),B(LDB,*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] SIDE +//> \verbatim +//> SIDE is 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 ). +//> \endverbatim +//> +//> \param[in] UPLO +//> \verbatim +//> UPLO is 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. +//> \endverbatim +//> +//> \param[in] TRANSA +//> \verbatim +//> TRANSA is 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**T. +//> +//> TRANSA = 'C' or 'c' op( A ) = A**T. +//> \endverbatim +//> +//> \param[in] DIAG +//> \verbatim +//> DIAG is 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. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is INTEGER +//> On entry, M specifies the number of rows of B. M must be at +//> least zero. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> On entry, N specifies the number of columns of B. N must be +//> at least zero. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is 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. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is 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 ). +//> \endverbatim +//> +//> \param[in,out] B +//> \verbatim +//> B is DOUBLE PRECISION array, 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. +//> \endverbatim +//> +//> \param[in] LDB +//> \verbatim +//> LDB is 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 ). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup double_blas_level3 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, + int *m, int *n, double *alpha, double *a, int *lda, double *b, int * + ldb) +{ + // System generated locals + int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + // Local variables + int i__, j, k, info; + double temp; + int lside; + extern int lsame_(char *, char *); + int nrowa; + int upper; + extern /* Subroutine */ int xerbla_(char *, int *); + int nounit; + + // + // -- Reference BLAS level3 routine (version 3.7.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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**T*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**T. + // + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +// L230: + } + } +// L240: + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +// L250: + } + } +// L260: + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +// L270: + } + } +// L280: + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +// L290: + } + } +// L300: + } + } + } + } + return 0; + // + // End of DTRMM . + // +} // dtrmm_ + diff --git a/3rdparty/clapack/src/dtrmv.c b/3rdparty/clapack/src/dtrmv.c new file mode 100644 index 0000000000..a989f12f8c --- /dev/null +++ b/3rdparty/clapack/src/dtrmv.c @@ -0,0 +1,396 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b DTRMV +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +// +// .. Scalar Arguments .. +// INTEGER INCX,LDA,N +// CHARACTER DIAG,TRANS,UPLO +// .. +// .. Array Arguments .. +// DOUBLE PRECISION A(LDA,*),X(*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> DTRMV performs one of the matrix-vector operations +//> +//> x := A*x, or x := A**T*x, +//> +//> where x is an n element vector and A is an n by n unit, or non-unit, +//> upper or lower triangular matrix. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] UPLO +//> \verbatim +//> UPLO is 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. +//> \endverbatim +//> +//> \param[in] TRANS +//> \verbatim +//> TRANS is 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**T*x. +//> +//> TRANS = 'C' or 'c' x := A**T*x. +//> \endverbatim +//> +//> \param[in] DIAG +//> \verbatim +//> DIAG is 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. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> On entry, N specifies the order of the matrix A. +//> N must be at least zero. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is DOUBLE PRECISION array, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is 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 ). +//> \endverbatim +//> +//> \param[in,out] X +//> \verbatim +//> X is DOUBLE PRECISION array, 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 +//> transformed vector x. +//> \endverbatim +//> +//> \param[in] INCX +//> \verbatim +//> INCX is INTEGER +//> On entry, INCX specifies the increment for the elements of +//> X. INCX must not be zero. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup double_blas_level2 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> Level 2 Blas routine. +//> The vector and matrix arguments are not referenced when N = 0, or M = 0 +//> +//> -- 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, int *n, + double *a, int *lda, double *x, int *incx) +{ + // System generated locals + int a_dim1, a_offset, i__1, i__2; + + // Local variables + int i__, j, ix, jx, kx, info; + double temp; + extern int lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, int *); + int nounit; + + // + // -- Reference BLAS level2 routine (version 3.7.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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**T*x. + // + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +// L90: + } + x[j] = temp; +// L100: + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + temp += a[i__ + j * a_dim1] * x[ix]; +// L110: + } + x[jx] = temp; + jx -= *incx; +// L120: + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +// L130: + } + x[j] = temp; +// L140: + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + temp += a[i__ + j * a_dim1] * x[ix]; +// L150: + } + x[jx] = temp; + jx += *incx; +// L160: + } + } + } + } + return 0; + // + // End of DTRMV . + // +} // dtrmv_ + diff --git a/3rdparty/clapack/src/ilaenv.c b/3rdparty/clapack/src/ilaenv.c new file mode 100644 index 0000000000..fc9003fcb1 --- /dev/null +++ b/3rdparty/clapack/src/ilaenv.c @@ -0,0 +1,1334 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b IEEECK +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download IEEECK + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +// +// .. Scalar Arguments .. +// INTEGER ISPEC +// REAL ONE, ZERO +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> IEEECK is called from the ILAENV to verify that Infinity and +//> possibly NaN arithmetic is safe (i.e. will not trap). +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] ISPEC +//> \verbatim +//> ISPEC is 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. +//> \endverbatim +//> +//> \param[in] ZERO +//> \verbatim +//> ZERO is REAL +//> Must contain the value 0.0 +//> This is passed to prevent the compiler from optimizing +//> away this code. +//> \endverbatim +//> +//> \param[in] ONE +//> \verbatim +//> ONE is 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 +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup OTHERauxiliary +// +// ===================================================================== +int ieeeck_(int *ispec, float *zero, float *one) +{ + // System generated locals + int ret_val; + + // Local variables + float nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro; + + // + // -- LAPACK auxiliary routine (version 3.7.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. 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 * *zero; + 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_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b ILAENV +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download ILAENV + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +// +// .. Scalar Arguments .. +// CHARACTER*( * ) NAME, OPTS +// INTEGER ISPEC, N1, N2, N3, N4 +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] ISPEC +//> \verbatim +//> ISPEC is 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 related subroutines, +//> see IPARMQ for detailed explanation +//> \endverbatim +//> +//> \param[in] NAME +//> \verbatim +//> NAME is CHARACTER*(*) +//> The name of the calling subroutine, in either upper case or +//> lower case. +//> \endverbatim +//> +//> \param[in] OPTS +//> \verbatim +//> OPTS is 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'. +//> \endverbatim +//> +//> \param[in] N1 +//> \verbatim +//> N1 is INTEGER +//> \endverbatim +//> +//> \param[in] N2 +//> \verbatim +//> N2 is INTEGER +//> \endverbatim +//> +//> \param[in] N3 +//> \verbatim +//> N3 is INTEGER +//> \endverbatim +//> +//> \param[in] N4 +//> \verbatim +//> N4 is INTEGER +//> Problem dimensions for the subroutine NAME; these may not all +//> be required. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date November 2019 +// +//> \ingroup OTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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 ) +//> \endverbatim +//> +// ===================================================================== +int ilaenv_(int *ispec, char *name__, char *opts, int *n1, int *n2, int *n3, + int *n4) +{ + // Table of constant values + int c__1 = 1; + float c_b174 = 0.f; + float c_b175 = 1.f; + int c__0 = 0; + + // System generated locals + int ret_val; + + // Local variables + int twostage; + int i__; + char c1[1+1]={'\0'}, c2[2+1]={'\0'}, c3[3+1]={'\0'}, c4[2+1]={'\0'}; + int ic, nb, iz, nx; + int cname; + int nbmin; + int sname; + extern int ieeeck_(int *, float *, float *); + char subnam[16+1]={'\0'}; + extern int iparmq_(int *, char *, char *, int *, int *, int *, int *); + + // + // -- LAPACK auxiliary routine (version 3.9.0) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // November 2019 + // + // .. Scalar Arguments .. + // .. + // + // ===================================================================== + // + // .. Local Scalars .. + // .. + // .. Intrinsic Functions .. + // .. + // .. External Functions .. + // .. + // .. Executable Statements .. + // + switch (*ispec) { + case 1: goto L10; + case 2: goto L10; + case 3: goto L10; + case 4: goto L80; + case 5: goto L90; + case 6: goto L100; + case 7: goto L110; + case 8: goto L120; + case 9: goto L130; + case 10: goto L140; + case 11: goto L150; + case 12: goto L160; + case 13: goto L160; + case 14: goto L160; + case 15: goto L160; + case 16: goto L160; + } + // + // Invalid value for ISPEC + // + ret_val = -1; + return ret_val; +L10: + // + // Convert NAME to upper case if the first character is lower case. + // + ret_val = 1; + s_copy(subnam, name__, (int)16); + ic = *(unsigned char *)subnam; + iz = 'Z'; + if (iz == 90 || iz == 122) { + // + // ASCII character set + // + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } +// L20: + } + } + } else if (iz == 233 || iz == 169) { + // + // EBCDIC character set + // + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && + ic <= 169) { + *(unsigned char *)subnam = (char) (ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= + 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); + } +// L30: + } + } + } else if (iz == 218 || iz == 250) { + // + // Prime machines: ASCII+128 + // + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } +// L40: + } + } + } + *(unsigned char *)c1 = *(unsigned char *)subnam; + sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D'; + cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z'; + if (! (cname || sname)) { + return ret_val; + } + s_copy(c2, subnam + 1, (int)2); + s_copy(c3, subnam + 3, (int)3); + s_copy(c4, c3 + 1, (int)2); + twostage = i_len(subnam) >= 11 && *(unsigned char *)&subnam[10] == '2'; + switch (*ispec) { + case 1: goto L50; + case 2: goto L60; + case 3: goto L70; + } +L50: + // + // 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. + // + nb = 1; + if (s_cmp(subnam + 1, "LAORH") == 0) { + // + // This is for *LAORHR_GETRFNP routine + // + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c2, "GE") == 0) { + if (s_cmp(c3, "TRF") == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, "QRF") == 0 || s_cmp(c3, "RQF") == 0 || s_cmp(c3, + "LQF") == 0 || s_cmp(c3, "QLF") == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "QR ") == 0) { + if (*n3 == 1) { + if (sname) { + // M*N + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } else { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } + } else { + if (sname) { + nb = 1; + } else { + nb = 1; + } + } + } else if (s_cmp(c3, "LQ ") == 0) { + if (*n3 == 2) { + if (sname) { + // M*N + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } else { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } + } else { + if (sname) { + nb = 1; + } else { + nb = 1; + } + } + } else if (s_cmp(c3, "HRD") == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "BRD") == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "TRI") == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "PO") == 0) { + if (s_cmp(c3, "TRF") == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "SY") == 0) { + if (s_cmp(c3, "TRF") == 0) { + if (sname) { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } else { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } + } else if (sname && s_cmp(c3, "TRD") == 0) { + nb = 32; + } else if (sname && s_cmp(c3, "GST") == 0) { + nb = 64; + } + } else if (cname && s_cmp(c2, "HE") == 0) { + if (s_cmp(c3, "TRF") == 0) { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } else if (s_cmp(c3, "TRD") == 0) { + nb = 32; + } else if (s_cmp(c3, "GST") == 0) { + nb = 64; + } + } else if (sname && s_cmp(c2, "OR") == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nb = 32; + } + } + } else if (cname && s_cmp(c2, "UN") == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nb = 32; + } + } + } else if (s_cmp(c2, "GB") == 0) { + if (s_cmp(c3, "TRF") == 0) { + if (sname) { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } + } else if (s_cmp(c2, "PB") == 0) { + if (s_cmp(c3, "TRF") == 0) { + if (sname) { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } + } else if (s_cmp(c2, "TR") == 0) { + if (s_cmp(c3, "TRI") == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, "EVC") == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "LA") == 0) { + if (s_cmp(c3, "UUM") == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (sname && s_cmp(c2, "ST") == 0) { + if (s_cmp(c3, "EBZ") == 0) { + nb = 1; + } + } else if (s_cmp(c2, "GG") == 0) { + nb = 32; + if (s_cmp(c3, "HD3") == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } + } + ret_val = nb; + return ret_val; +L60: + // + // ISPEC = 2: minimum block size + // + nbmin = 2; + if (s_cmp(c2, "GE") == 0) { + if (s_cmp(c3, "QRF") == 0 || s_cmp(c3, "RQF") == 0 || s_cmp(c3, "LQF") + == 0 || s_cmp(c3, "QLF") == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "HRD") == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "BRD") == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "TRI") == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } + } else if (s_cmp(c2, "SY") == 0) { + if (s_cmp(c3, "TRF") == 0) { + if (sname) { + nbmin = 8; + } else { + nbmin = 8; + } + } else if (sname && s_cmp(c3, "TRD") == 0) { + nbmin = 2; + } + } else if (cname && s_cmp(c2, "HE") == 0) { + if (s_cmp(c3, "TRD") == 0) { + nbmin = 2; + } + } else if (sname && s_cmp(c2, "OR") == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nbmin = 2; + } + } + } else if (cname && s_cmp(c2, "UN") == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nbmin = 2; + } + } + } else if (s_cmp(c2, "GG") == 0) { + nbmin = 2; + if (s_cmp(c3, "HD3") == 0) { + nbmin = 2; + } + } + ret_val = nbmin; + return ret_val; +L70: + // + // ISPEC = 3: crossover point + // + nx = 0; + if (s_cmp(c2, "GE") == 0) { + if (s_cmp(c3, "QRF") == 0 || s_cmp(c3, "RQF") == 0 || s_cmp(c3, "LQF") + == 0 || s_cmp(c3, "QLF") == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_cmp(c3, "HRD") == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_cmp(c3, "BRD") == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } + } else if (s_cmp(c2, "SY") == 0) { + if (sname && s_cmp(c3, "TRD") == 0) { + nx = 32; + } + } else if (cname && s_cmp(c2, "HE") == 0) { + if (s_cmp(c3, "TRD") == 0) { + nx = 32; + } + } else if (sname && s_cmp(c2, "OR") == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nx = 128; + } + } + } else if (cname && s_cmp(c2, "UN") == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR") == 0 || s_cmp(c4, "RQ") == 0 || s_cmp(c4, + "LQ") == 0 || s_cmp(c4, "QL") == 0 || s_cmp(c4, "HR") == + 0 || s_cmp(c4, "TR") == 0 || s_cmp(c4, "BR") == 0) { + nx = 128; + } + } + } else if (s_cmp(c2, "GG") == 0) { + nx = 128; + if (s_cmp(c3, "HD3") == 0) { + nx = 128; + } + } + ret_val = nx; + return ret_val; +L80: + // + // ISPEC = 4: number of shifts (used by xHSEQR) + // + ret_val = 6; + return ret_val; +L90: + // + // ISPEC = 5: minimum column dimension (not used) + // + ret_val = 2; + return ret_val; +L100: + // + // ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) + // + ret_val = (int) ((float) min(*n1,*n2) * 1.6f); + return ret_val; +L110: + // + // ISPEC = 7: number of processors (not used) + // + ret_val = 1; + return ret_val; +L120: + // + // ISPEC = 8: crossover point for multishift (used by xHSEQR) + // + ret_val = 50; + return ret_val; +L130: + // + // 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) + // + ret_val = 25; + return ret_val; +L140: + // + // ISPEC = 10: ieee NaN arithmetic can be trusted not to trap + // + // ILAENV = 0 + ret_val = 1; + if (ret_val == 1) { + ret_val = ieeeck_(&c__1, &c_b174, &c_b175); + } + return ret_val; +L150: + // + // ISPEC = 11: infinity arithmetic can be trusted not to trap + // + // ILAENV = 0 + ret_val = 1; + if (ret_val == 1) { + ret_val = ieeeck_(&c__0, &c_b174, &c_b175); + } + return ret_val; +L160: + // + // 12 <= ISPEC <= 16: xHSEQR or related subroutines. + // + ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4); + return ret_val; + // + // End of ILAENV + // +} // ilaenv_ + +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +//> \brief \b IPARMQ +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +//> \htmlonly +//> Download IPARMQ + dependencies +//> +//> [TGZ] +//> +//> [ZIP] +//> +//> [TXT] +//> \endhtmlonly +// +// Definition: +// =========== +// +// INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +// +// .. Scalar Arguments .. +// INTEGER IHI, ILO, ISPEC, LWORK, N +// CHARACTER NAME*( * ), OPTS*( * ) +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> This program sets problem and machine dependent parameters +//> useful for xHSEQR and related subroutines for eigenvalue +//> problems. It is called whenever +//> IPARMQ is called with 12 <= ISPEC <= 16 +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] ISPEC +//> \verbatim +//> ISPEC is INTEGER +//> 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 > (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/QZ sweep, +//> blocked eigenvalue reordering, blocked +//> Hessenberg-triangular reduction, +//> reflections and/or rotations are not +//> accumulated when updating the +//> far-from-diagonal matrix entries. +//> 1: During the multi-shift QR/QZ sweep, +//> blocked eigenvalue reordering, blocked +//> Hessenberg-triangular reduction, +//> reflections and/or rotations are +//> accumulated, and matrix-matrix +//> multiplication is used to update the +//> far-from-diagonal matrix entries. +//> 2: During the multi-shift QR/QZ sweep, +//> blocked eigenvalue reordering, blocked +//> Hessenberg-triangular reduction, +//> reflections and/or rotations are +//> accumulated, and 2-by-2 block structure +//> is exploited 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.) +//> \endverbatim +//> +//> \param[in] NAME +//> \verbatim +//> NAME is CHARACTER string +//> Name of the calling subroutine +//> \endverbatim +//> +//> \param[in] OPTS +//> \verbatim +//> OPTS is CHARACTER string +//> This is a concatenation of the string arguments to +//> TTQRE. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is INTEGER +//> N is the order of the Hessenberg matrix H. +//> \endverbatim +//> +//> \param[in] ILO +//> \verbatim +//> ILO is INTEGER +//> \endverbatim +//> +//> \param[in] IHI +//> \verbatim +//> IHI is INTEGER +//> It is assumed that H is already upper triangular +//> in rows and columns 1:ILO-1 and IHI+1:N. +//> \endverbatim +//> +//> \param[in] LWORK +//> \verbatim +//> LWORK is INTEGER +//> The amount of workspace available. +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date June 2017 +// +//> \ingroup OTHERauxiliary +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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) <= 500 is NS. The default +//> for (IHI-ILO+1) > 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. +//> \endverbatim +//> +// ===================================================================== +int iparmq_(int *ispec, char *name__, char *opts, int *n, int *ilo, int *ihi, + int *lwork) +{ + // System generated locals + int ret_val, i__1, i__2; + float r__1; + + // Local variables + int i__, ic, nh, ns, iz; + char subnam[6+1]={'\0'}; + + // + // -- LAPACK auxiliary routine (version 3.7.1) -- + // -- LAPACK is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // June 2017 + // + // .. Scalar Arguments .. + // + // ================================================================ + // .. 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((float) 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. + // + // + // Convert NAME to upper case if the first character is lower case. + // + ret_val = 0; + s_copy(subnam, name__, (int)6); + ic = *(unsigned char *)subnam; + iz = 'Z'; + if (iz == 90 || iz == 122) { + // + // ASCII character set + // + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } + } + } + } else if (iz == 233 || iz == 169) { + // + // EBCDIC character set + // + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 + && ic <= 169) { + *(unsigned char *)subnam = (char) (ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || + ic >= 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); + } + } + } + } else if (iz == 218 || iz == 250) { + // + // Prime machines: ASCII+128 + // + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } + } + } + } + if (s_cmp(subnam + 1, "GGHRD") == 0 || s_cmp(subnam + 1, "GGHD3") == + 0) { + ret_val = 1; + if (nh >= 14) { + ret_val = 2; + } + } else if (s_cmp(subnam + 3, "EXC") == 0) { + if (nh >= 14) { + ret_val = 1; + } + if (nh >= 14) { + ret_val = 2; + } + } else if (s_cmp(subnam + 1, "HSEQR") == 0 || s_cmp(subnam + 1, "LAQR" + ) == 0) { + if (ns >= 14) { + ret_val = 1; + } + if (ns >= 14) { + ret_val = 2; + } + } + } else { + // ===== invalid value of ispec ===== + ret_val = -1; + } + // + // ==== End of IPARMQ ==== + // + return ret_val; +} // iparmq_ + diff --git a/3rdparty/clapack/src/sgemm.c b/3rdparty/clapack/src/sgemm.c new file mode 100644 index 0000000000..dd82bdb7d3 --- /dev/null +++ b/3rdparty/clapack/src/sgemm.c @@ -0,0 +1,444 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b SGEMM +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +// +// .. Scalar Arguments .. +// REAL ALPHA,BETA +// INTEGER K,LDA,LDB,LDC,M,N +// CHARACTER TRANSA,TRANSB +// .. +// .. Array Arguments .. +// REAL A(LDA,*),B(LDB,*),C(LDC,*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> 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**T, +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] TRANSA +//> \verbatim +//> TRANSA is 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**T. +//> +//> TRANSA = 'C' or 'c', op( A ) = A**T. +//> \endverbatim +//> +//> \param[in] TRANSB +//> \verbatim +//> TRANSB is 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**T. +//> +//> TRANSB = 'C' or 'c', op( B ) = B**T. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is 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. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is 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. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is 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. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is REAL +//> On entry, ALPHA specifies the scalar alpha. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is REAL array, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is 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 ). +//> \endverbatim +//> +//> \param[in] B +//> \verbatim +//> B is REAL array, 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. +//> \endverbatim +//> +//> \param[in] LDB +//> \verbatim +//> LDB is 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 ). +//> \endverbatim +//> +//> \param[in] BETA +//> \verbatim +//> BETA is REAL +//> On entry, BETA specifies the scalar beta. When BETA is +//> supplied as zero then C need not be set on input. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is REAL array, 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 ). +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is 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 ). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup single_blas_level3 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int sgemm_(char *transa, char *transb, int *m, int *n, int * + k, float *alpha, float *a, int *lda, float *b, int *ldb, float *beta, + float *c__, int *ldc) +{ + // System generated locals + int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + // Local variables + int i__, j, l, info; + int nota, notb; + float temp; + int ncola; + extern int lsame_(char *, char *); + int nrowa, nrowb; + extern /* Subroutine */ int xerbla_(char *, int *); + + // + // -- Reference BLAS level3 routine (version 3.7.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. 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) { + 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**T*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**T + 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) { + 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**T*B**T + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; +// L180: + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +// L190: + } +// L200: + } + } + } + return 0; + // + // End of SGEMM . + // +} // sgemm_ + diff --git a/3rdparty/clapack/src/zgemm.c b/3rdparty/clapack/src/zgemm.c new file mode 100644 index 0000000000..93a7dd7bda --- /dev/null +++ b/3rdparty/clapack/src/zgemm.c @@ -0,0 +1,752 @@ +/* -- translated by f2c (version 20201020 (for_lapack)). -- */ + +#include "f2c.h" + +//> \brief \b ZGEMM +// +// =========== DOCUMENTATION =========== +// +// Online html documentation available at +// http://www.netlib.org/lapack/explore-html/ +// +// Definition: +// =========== +// +// SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +// +// .. Scalar Arguments .. +// COMPLEX*16 ALPHA,BETA +// INTEGER K,LDA,LDB,LDC,M,N +// CHARACTER TRANSA,TRANSB +// .. +// .. Array Arguments .. +// COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +// .. +// +// +//> \par Purpose: +// ============= +//> +//> \verbatim +//> +//> ZGEMM 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**T or op( X ) = X**H, +//> +//> 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. +//> \endverbatim +// +// Arguments: +// ========== +// +//> \param[in] TRANSA +//> \verbatim +//> TRANSA is 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**T. +//> +//> TRANSA = 'C' or 'c', op( A ) = A**H. +//> \endverbatim +//> +//> \param[in] TRANSB +//> \verbatim +//> TRANSB is 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**T. +//> +//> TRANSB = 'C' or 'c', op( B ) = B**H. +//> \endverbatim +//> +//> \param[in] M +//> \verbatim +//> M is 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. +//> \endverbatim +//> +//> \param[in] N +//> \verbatim +//> N is 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. +//> \endverbatim +//> +//> \param[in] K +//> \verbatim +//> K is 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. +//> \endverbatim +//> +//> \param[in] ALPHA +//> \verbatim +//> ALPHA is COMPLEX*16 +//> On entry, ALPHA specifies the scalar alpha. +//> \endverbatim +//> +//> \param[in] A +//> \verbatim +//> A is COMPLEX*16 array, 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. +//> \endverbatim +//> +//> \param[in] LDA +//> \verbatim +//> LDA is 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 ). +//> \endverbatim +//> +//> \param[in] B +//> \verbatim +//> B is COMPLEX*16 array, 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. +//> \endverbatim +//> +//> \param[in] LDB +//> \verbatim +//> LDB is 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 ). +//> \endverbatim +//> +//> \param[in] BETA +//> \verbatim +//> BETA is COMPLEX*16 +//> On entry, BETA specifies the scalar beta. When BETA is +//> supplied as zero then C need not be set on input. +//> \endverbatim +//> +//> \param[in,out] C +//> \verbatim +//> C is COMPLEX*16 array, 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 ). +//> \endverbatim +//> +//> \param[in] LDC +//> \verbatim +//> LDC is 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 ). +//> \endverbatim +// +// Authors: +// ======== +// +//> \author Univ. of Tennessee +//> \author Univ. of California Berkeley +//> \author Univ. of Colorado Denver +//> \author NAG Ltd. +// +//> \date December 2016 +// +//> \ingroup complex16_blas_level3 +// +//> \par Further Details: +// ===================== +//> +//> \verbatim +//> +//> 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. +//> \endverbatim +//> +// ===================================================================== +/* Subroutine */ int zgemm_(char *transa, char *transb, int *m, int *n, int * + k, doublecomplex *alpha, doublecomplex *a, int *lda, doublecomplex *b, + int *ldb, doublecomplex *beta, doublecomplex *c__, int *ldc) +{ + // Table of constant values + doublecomplex c_b1 = {1.,0.}; + doublecomplex c_b2 = {0.,0.}; + + // System generated locals + int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + doublecomplex z__1, z__2, z__3, z__4; + + // Local variables + int i__, j, l, info; + int nota, notb; + doublecomplex temp; + int conja, conjb; + int ncola; + extern int lsame_(char *, char *); + int nrowa, nrowb; + extern /* Subroutine */ int xerbla_(char *, int *); + + // + // -- Reference BLAS level3 routine (version 3.7.0) -- + // -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + // -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + // December 2016 + // + // .. Scalar Arguments .. + // .. + // .. Array Arguments .. + // .. + // + // ===================================================================== + // + // .. External Functions .. + // .. + // .. External Subroutines .. + // .. + // .. Intrinsic Functions .. + // .. + // .. Local Scalars .. + // .. + // .. Parameters .. + // .. + // + // Set NOTA and NOTB as true if A and B respectively are not + // conjugated or transposed, set CONJA and CONJB as true if A and + // B respectively are to be transposed but not conjugated 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"); + conja = lsame_(transa, "C"); + conjb = lsame_(transb, "C"); + 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 && ! conja && ! lsame_(transa, "T")) { + info = 1; + } else if (! notb && ! conjb && ! 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_("ZGEMM ", &info); + return 0; + } + // + // Quick return if possible. + // + if (*m == 0 || *n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && + (beta->r == 1. && beta->i == 0.)) { + return 0; + } + // + // And when alpha.eq.zero. + // + if (alpha->r == 0. && alpha->i == 0.) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +// L10: + } +// L20: + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + z__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +// 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->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +// L50: + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +// L60: + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +// L70: + } +// L80: + } +// L90: + } + } else if (conja) { + // + // Form C := alpha*A**H*B + beta*C. + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +// L100: + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +// L110: + } +// L120: + } + } else { + // + // Form C := alpha*A**T*B + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +// L130: + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +// L140: + } +// L150: + } + } + } else if (nota) { + if (conjb) { + // + // Form C := alpha*A*B**H + beta*C. + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +// L160: + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +// L170: + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + d_cnjg(&z__2, &b[j + l * b_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +// L180: + } +// L190: + } +// L200: + } + } else { + // + // Form C := alpha*A*B**T + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +// L210: + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +// L220: + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +// L230: + } +// L240: + } +// L250: + } + } + } else if (conja) { + if (conjb) { + // + // Form C := alpha*A**H*B**H + beta*C. + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + d_cnjg(&z__4, &b[j + l * b_dim1]); + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = + z__3.r * z__4.i + z__3.i * z__4.r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +// L260: + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +// L270: + } +// L280: + } + } else { + // + // Form C := alpha*A**H*B**T + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = j + l * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +// L290: + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +// L300: + } +// L310: + } + } + } else { + if (conjb) { + // + // Form C := alpha*A**T*B**H + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + d_cnjg(&z__3, &b[j + l * b_dim1]); + z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i, + z__2.i = a[i__4].r * z__3.i + a[i__4].i * + z__3.r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +// L320: + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +// L330: + } +// L340: + } + } else { + // + // Form C := alpha*A**T*B**T + beta*C + // + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = j + l * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +// L350: + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +// L360: + } +// L370: + } + } + } + return 0; + // + // End of ZGEMM . + // +} // zgemm_ + diff --git a/CMakeLists.txt b/CMakeLists.txt index 4350b2fe2a..746b50f8cb 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -227,6 +227,7 @@ OCV_OPTION(BUILD_ITT "Build Intel ITT from source" (NOT MINGW OR OPENCV_FORCE_3RDPARTY_BUILD) IF (X86_64 OR X86 OR ARM OR AARCH64 OR PPC64 OR PPC64LE) AND NOT WINRT AND NOT APPLE_FRAMEWORK ) +OCV_OPTION(BUILD_CLAPACK "Build CLapack from source" (((WIN32 OR ANDROID) AND NOT APPLE) OR OPENCV_FORCE_3RDPARTY_BUILD) ) # Optional 3rd party components # =================================================== @@ -695,6 +696,9 @@ include(cmake/OpenCVFindLibsGUI.cmake) include(cmake/OpenCVFindLibsVideo.cmake) include(cmake/OpenCVFindLibsPerf.cmake) include(cmake/OpenCVFindLAPACK.cmake) +if(WITH_LAPACK) + ocv_assert(HAVE_LAPACK) # Lapack is required for OpenCV 5.0+ +endif() include(cmake/OpenCVFindProtobuf.cmake) if(WITH_TENGINE) include(cmake/OpenCVFindTengine.cmake) @@ -1439,7 +1443,7 @@ if(WITH_TENGINE OR HAVE_TENGINE) endif() if(WITH_LAPACK OR HAVE_LAPACK) - status(" Lapack:" HAVE_LAPACK THEN "YES (${LAPACK_LIBRARIES})" ELSE NO) + status(" Lapack:" HAVE_LAPACK THEN "YES (${LAPACK_LIBRARIES} ${LAPACK_VERSION})" ELSE NO) endif() if(WITH_HALIDE OR HAVE_HALIDE) diff --git a/cmake/OpenCVFindLAPACK.cmake b/cmake/OpenCVFindLAPACK.cmake index 342bebc723..3fa23ef83f 100644 --- a/cmake/OpenCVFindLAPACK.cmake +++ b/cmake/OpenCVFindLAPACK.cmake @@ -20,25 +20,17 @@ macro(_find_header_file_in_dirs VAR NAME) endif() endmacro() -macro(ocv_lapack_check) - string(REGEX REPLACE "[^a-zA-Z0-9_]" "_" _lapack_impl "${LAPACK_IMPL}") - message(STATUS "LAPACK(${LAPACK_IMPL}): LAPACK_LIBRARIES: ${LAPACK_LIBRARIES}") - _find_header_file_in_dirs(OPENCV_CBLAS_H_PATH_${_lapack_impl} "${LAPACK_CBLAS_H}" "${LAPACK_INCLUDE_DIR}") - _find_header_file_in_dirs(OPENCV_LAPACKE_H_PATH_${_lapack_impl} "${LAPACK_LAPACKE_H}" "${LAPACK_INCLUDE_DIR}") - if(NOT OPENCV_CBLAS_H_PATH_${_lapack_impl} OR NOT OPENCV_LAPACKE_H_PATH_${_lapack_impl}) - message(WARNING "LAPACK(${LAPACK_IMPL}): CBLAS/LAPACK headers are not found in '${LAPACK_INCLUDE_DIR}'") - unset(LAPACK_LIBRARIES) - else() - # adding proxy opencv_lapack.h header - set(CBLAS_H_PROXY_PATH ${CMAKE_BINARY_DIR}/opencv_lapack.h) +macro(ocv_lapack_make_hdr _cblas_hdr _lapacke_hdr) + # adding proxy opencv_lapack.h header + set(CBLAS_H_PROXY_PATH ${CMAKE_BINARY_DIR}/opencv_lapack.h) - set(_lapack_add_extern_c NOT (APPLE OR OPENCV_SKIP_LAPACK_EXTERN_C) OR OPENCV_FORCE_LAPACK_EXTERN_C) + set(_lapack_add_extern_c NOT (APPLE OR OPENCV_SKIP_LAPACK_EXTERN_C) OR OPENCV_FORCE_LAPACK_EXTERN_C) - set(_lapack_content "// This file is auto-generated\n") - if(${_lapack_add_extern_c}) - list(APPEND _lapack_content "extern \"C\" {") - endif() - if(NOT OPENCV_SKIP_LAPACK_MSVC_FIX) + set(_lapack_content "// This file is auto-generated\n") + if(${_lapack_add_extern_c}) + list(APPEND _lapack_content "extern \"C\" {") + endif() + if(NOT OPENCV_SKIP_LAPACK_MSVC_FIX) list(APPEND _lapack_content " #ifdef _MSC_VER #include @@ -46,41 +38,58 @@ macro(ocv_lapack_check) #define lapack_complex_double _Dcomplex #endif ") - endif() - list(APPEND _lapack_content "#include \"${OPENCV_CBLAS_H_PATH_${_lapack_impl}}\"") - if(NOT "${OPENCV_CBLAS_H_PATH_${_lapack_impl}}" STREQUAL "${OPENCV_LAPACKE_H_PATH_${_lapack_impl}}") - list(APPEND _lapack_content "#include \"${OPENCV_LAPACKE_H_PATH_${_lapack_impl}}\"") - endif() - if(${_lapack_add_extern_c}) - list(APPEND _lapack_content "}") - endif() + endif() + list(APPEND _lapack_content "#include \"${_cblas_hdr}\"") + if(NOT "${_cblas_hdr}" STREQUAL "${_lapacke_hdr}") + list(APPEND _lapack_content "#include \"${_lapacke_hdr}\"") + endif() + if(${_lapack_add_extern_c}) + list(APPEND _lapack_content "}") + endif() + string(REPLACE ";" "\n" _lapack_content "${_lapack_content}") + ocv_update_file("${CBLAS_H_PROXY_PATH}" "${_lapack_content}") +endmacro() - string(REPLACE ";" "\n" _lapack_content "${_lapack_content}") - ocv_update_file("${CBLAS_H_PROXY_PATH}" "${_lapack_content}") +macro(ocv_lapack_run_check) + try_compile(__VALID_LAPACK + "${OpenCV_BINARY_DIR}" + "${OpenCV_SOURCE_DIR}/cmake/checks/lapack_check.cpp" + CMAKE_FLAGS "-DINCLUDE_DIRECTORIES:STRING=${LAPACK_INCLUDE_DIR}\;${CMAKE_BINARY_DIR}" + "-DLINK_DIRECTORIES:STRING=${LAPACK_LINK_LIBRARIES}" + "-DLINK_LIBRARIES:STRING=${LAPACK_LIBRARIES}" + OUTPUT_VARIABLE TRY_OUT + ) + if(NOT __VALID_LAPACK) + #message(FATAL_ERROR "LAPACK: check build log:\n${TRY_OUT}") + message(STATUS "${LAPACK_IMPL}: Can't build LAPACK check code. This LAPACK version is not supported.") + unset(LAPACK_LIBRARIES) + else() + message(STATUS "${LAPACK_IMPL}: Support is enabled.") + ocv_include_directories(${LAPACK_INCLUDE_DIR}) + set(HAVE_LAPACK 1) + endif() +endmacro() - try_compile(__VALID_LAPACK - "${OpenCV_BINARY_DIR}" - "${OpenCV_SOURCE_DIR}/cmake/checks/lapack_check.cpp" - CMAKE_FLAGS "-DINCLUDE_DIRECTORIES:STRING=${LAPACK_INCLUDE_DIR}\;${CMAKE_BINARY_DIR}" - "-DLINK_DIRECTORIES:STRING=${LAPACK_LINK_LIBRARIES}" - "-DLINK_LIBRARIES:STRING=${LAPACK_LIBRARIES}" - OUTPUT_VARIABLE TRY_OUT - ) - if(NOT __VALID_LAPACK) - #message(FATAL_ERROR "LAPACK: check build log:\n${TRY_OUT}") - message(STATUS "LAPACK(${LAPACK_IMPL}): Can't build LAPACK check code. This LAPACK version is not supported.") - unset(LAPACK_LIBRARIES) - else() - message(STATUS "LAPACK(${LAPACK_IMPL}): Support is enabled.") - ocv_include_directories(${LAPACK_INCLUDE_DIR}) - set(HAVE_LAPACK 1) - endif() +macro(ocv_lapack_check) + string(REGEX REPLACE "[^a-zA-Z0-9_]" "_" _lapack_impl "${LAPACK_IMPL}") + message(STATUS "${LAPACK_IMPL}: LAPACK_LIBRARIES=${LAPACK_LIBRARIES}") + _find_header_file_in_dirs(OPENCV_CBLAS_H_PATH_${_lapack_impl} "${LAPACK_CBLAS_H}" "${LAPACK_INCLUDE_DIR}") + _find_header_file_in_dirs(OPENCV_LAPACKE_H_PATH_${_lapack_impl} "${LAPACK_LAPACKE_H}" "${LAPACK_INCLUDE_DIR}") + message(STATUS "${LAPACK_IMPL}: Looking for CBLAS/LAPACK headers in '${LAPACK_INCLUDE_DIR}': '${OPENCV_CBLAS_H_PATH_${_lapack_impl}}', '${OPENCV_LAPACKE_H_PATH_${_lapack_impl}}'") + if(OPENCV_CBLAS_H_PATH_${_lapack_impl} AND OPENCV_LAPACKE_H_PATH_${_lapack_impl}) + ocv_lapack_make_hdr(${OPENCV_CBLAS_H_PATH_${_lapack_impl}} ${OPENCV_LAPACKE_H_PATH_${_lapack_impl}}) + ocv_lapack_run_check() + else() + unset(LAPACK_LIBRARIES) endif() endmacro() if(WITH_LAPACK) + unset(LAPACK_LIBRARIES) + unset(LAPACK_LIBRARIES CACHE) + ocv_update(LAPACK_IMPL "Unknown") - if(NOT OPENCV_LAPACK_FIND_PACKAGE_ONLY) + if(NOT BUILD_CLAPACK AND NOT OPENCV_LAPACK_FIND_PACKAGE_ONLY) if(NOT LAPACK_LIBRARIES AND NOT OPENCV_LAPACK_DISABLE_MKL) include(cmake/OpenCVFindMKL.cmake) if(HAVE_MKL) @@ -89,6 +98,7 @@ if(WITH_LAPACK) set(LAPACK_CBLAS_H "mkl_cblas.h") set(LAPACK_LAPACKE_H "mkl_lapack.h") set(LAPACK_IMPL "MKL") + set(LAPACK_VERSION "${MKL_VERSION_STR}") ocv_lapack_check() endif() endif() @@ -116,7 +126,7 @@ if(WITH_LAPACK) endif() endif() - if(NOT LAPACK_LIBRARIES) + if(NOT BUILD_CLAPACK AND NOT LAPACK_LIBRARIES) if(WIN32 AND NOT OPENCV_LAPACK_SHARED_LIBS) set(BLA_STATIC 1) endif() @@ -142,31 +152,45 @@ if(WITH_LAPACK) set(LAPACK_LAPACKE_H "lapacke.h") set(LAPACK_IMPL "LAPACK/Generic") ocv_lapack_check() - elseif(APPLE) - set(LAPACK_CBLAS_H "Accelerate/Accelerate.h") - set(LAPACK_LAPACKE_H "Accelerate/Accelerate.h") - set(LAPACK_IMPL "LAPACK/Apple") - ocv_lapack_check() endif() endif() endif() - if(NOT HAVE_LAPACK) + endif() + + if(NOT HAVE_LAPACK) + if(LAPACK_LIBRARIES AND LAPACK_CBLAS_H AND LAPACK_LAPACKE_H) + ocv_lapack_check() + else() unset(LAPACK_LIBRARIES) unset(LAPACK_LIBRARIES CACHE) endif() endif() - if(NOT LAPACK_LIBRARIES AND APPLE AND NOT OPENCV_LAPACK_FIND_PACKAGE_ONLY) + if(NOT BUILD_CLAPACK AND APPLE AND NOT LAPACK_LIBRARIES) set(LAPACK_INCLUDE_DIR "") set(LAPACK_LIBRARIES "-framework Accelerate") set(LAPACK_CBLAS_H "Accelerate/Accelerate.h") set(LAPACK_LAPACKE_H "Accelerate/Accelerate.h") - set(LAPACK_IMPL "Apple") + set(LAPACK_IMPL "LAPACK/Apple") ocv_lapack_check() endif() - if(NOT HAVE_LAPACK AND LAPACK_LIBRARIES AND LAPACK_CBLAS_H AND LAPACK_LAPACKE_H) - ocv_lapack_check() + if(BUILD_CLAPACK) + ocv_assert(NOT HAVE_LAPACK) + endif() + if(NOT HAVE_LAPACK) # OR BUILD_CLAPACK=ON + add_subdirectory(3rdparty/clapack) + + set(LAPACK_CBLAS_H "cblas.h") + set(LAPACK_LAPACKE_H "lapack.h") + set(LAPACK_IMPL "LAPACK/clapack") + set(LAPACK_INCLUDE_DIR "${CLAPACK_INCLUDE_DIR}") + set(LAPACK_LIBRARIES ${CLAPACK_LIBRARIES}) + set(LAPACK_VERSION "${CLAPACK_VERSION}") + ocv_lapack_make_hdr("${LAPACK_INCLUDE_DIR}/${LAPACK_CBLAS_H}" "${LAPACK_INCLUDE_DIR}/${LAPACK_LAPACKE_H}") + # unable to properly check against source code without binaries: ocv_lapack_check() + ocv_include_directories(${LAPACK_INCLUDE_DIR}) + set(HAVE_LAPACK 1) endif() set(LAPACK_INCLUDE_DIR ${LAPACK_INCLUDE_DIR} CACHE PATH "Path to BLAS include dir" FORCE) diff --git a/modules/core/src/hal_internal.cpp b/modules/core/src/hal_internal.cpp index 60f96c0164..a31d1aa672 100644 --- a/modules/core/src/hal_internal.cpp +++ b/modules/core/src/hal_internal.cpp @@ -100,7 +100,7 @@ template static inline int lapack_LU(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n, int* info) { int lda = (int)(a_step / sizeof(fptype)), sign = 0; - int* piv = new int[m]; + std::vector piv(m+1); transpose_square_inplace(a, lda, m); @@ -109,34 +109,35 @@ lapack_LU(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n, int* if(n == 1 && b_step == sizeof(fptype)) { if(typeid(fptype) == typeid(float)) - sgesv_(&m, &n, (float*)a, &lda, piv, (float*)b, &m, info); + sgesv_(&m, &n, (float*)a, &lda, &piv[0], (float*)b, &m, info); else if(typeid(fptype) == typeid(double)) - dgesv_(&m, &n, (double*)a, &lda, piv, (double*)b, &m, info); + dgesv_(&m, &n, (double*)a, &lda, &piv[0], (double*)b, &m, info); } else { int ldb = (int)(b_step / sizeof(fptype)); - fptype* tmpB = new fptype[m*n]; + std::vector tmpB(m*n+1); - transpose(b, ldb, tmpB, m, m, n); + transpose(b, ldb, &tmpB[0], m, m, n); if(typeid(fptype) == typeid(float)) - sgesv_(&m, &n, (float*)a, &lda, piv, (float*)tmpB, &m, info); + sgesv_(&m, &n, (float*)a, &lda, &piv[0], (float*)&tmpB[0], &m, info); else if(typeid(fptype) == typeid(double)) - dgesv_(&m, &n, (double*)a, &lda, piv, (double*)tmpB, &m, info); + dgesv_(&m, &n, (double*)a, &lda, &piv[0], (double*)&tmpB[0], &m, info); - transpose(tmpB, m, b, ldb, n, m); - delete[] tmpB; + transpose(&tmpB[0], m, b, ldb, n, m); } } else { if(typeid(fptype) == typeid(float)) - sgetrf_(&m, &m, (float*)a, &lda, piv, info); + sgetrf_(&m, &m, (float*)a, &lda, &piv[0], info); else if(typeid(fptype) == typeid(double)) - dgetrf_(&m, &m, (double*)a, &lda, piv, info); + dgetrf_(&m, &m, (double*)a, &lda, &piv[0], info); } + int retcode = *info >= 0 ? CV_HAL_ERROR_OK : CV_HAL_ERROR_NOT_IMPLEMENTED; + if(*info == 0) { for(int i = 0; i < m; i++) @@ -146,8 +147,7 @@ lapack_LU(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n, int* else *info = 0; //in opencv LU function zero means error - delete[] piv; - return CV_HAL_ERROR_OK; + return retcode; } template static inline int @@ -192,7 +192,7 @@ lapack_Cholesky(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n if(lapackStatus == 0) *info = true; else *info = false; //in opencv Cholesky function false means error - return CV_HAL_ERROR_OK; + return lapackStatus >= 0 ? CV_HAL_ERROR_OK : CV_HAL_ERROR_NOT_IMPLEMENTED; } template static inline int @@ -202,7 +202,8 @@ lapack_SVD(fptype* a, size_t a_step, fptype *w, fptype* u, size_t u_step, fptype int ldv = (int)(v_step / sizeof(fptype)); int ldu = (int)(u_step / sizeof(fptype)); int lwork = -1; - int* iworkBuf = new int[8*std::min(m, n)]; + std::vector iworkBuf(8*std::min(m, n)); + std::vector ubuf; fptype work1 = 0; //A already transposed and m>=n @@ -221,22 +222,30 @@ lapack_SVD(fptype* a, size_t a_step, fptype *w, fptype* u, size_t u_step, fptype if((flags & CV_HAL_SVD_MODIFY_A) && (flags & CV_HAL_SVD_FULL_UV)) //U stored in a { - u = new fptype[m*m]; + ubuf.resize(m*m); + u = &ubuf[0]; ldu = m; } if(typeid(fptype) == typeid(float)) - sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu, (float*)vt, &ldv, (float*)&work1, &lwork, iworkBuf, info); + sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu, + (float*)vt, &ldv, (float*)&work1, &lwork, &iworkBuf[0], info); else if(typeid(fptype) == typeid(double)) - dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu, (double*)vt, &ldv, (double*)&work1, &lwork, iworkBuf, info); + dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu, + (double*)vt, &ldv, (double*)&work1, &lwork, &iworkBuf[0], info); + + if(*info < 0) + return CV_HAL_ERROR_NOT_IMPLEMENTED; lwork = (int)round(work1); //optimal buffer size - fptype* buffer = new fptype[lwork + 1]; + std::vector buffer(lwork + 1); if(typeid(fptype) == typeid(float)) - sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu, (float*)vt, &ldv, (float*)buffer, &lwork, iworkBuf, info); + sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu, + (float*)vt, &ldv, (float*)&buffer[0], &lwork, &iworkBuf[0], info); else if(typeid(fptype) == typeid(double)) - dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu, (double*)vt, &ldv, (double*)buffer, &lwork, iworkBuf, info); + dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu, + (double*)vt, &ldv, (double*)&buffer[0], &lwork, &iworkBuf[0], info); if(!(flags & CV_HAL_SVD_NO_UV)) transpose_square_inplace(vt, ldv, n); @@ -246,11 +255,10 @@ lapack_SVD(fptype* a, size_t a_step, fptype *w, fptype* u, size_t u_step, fptype for(int i = 0; i < m; i++) for(int j = 0; j < m; j++) a[i*lda + j] = u[i*m + j]; - delete[] u; } - delete[] iworkBuf; - delete[] buffer; + if(*info < 0) + return CV_HAL_ERROR_NOT_IMPLEMENTED; return CV_HAL_ERROR_OK; } @@ -291,6 +299,9 @@ lapack_QR(fptype* a, size_t a_step, int m, int n, int k, fptype* b, size_t b_ste else if (typeid(fptype) == typeid(double)) dgels_(mode, &m, &n, &k, (double*)tmpA, &ldtmpA, (double*)b, &m, (double*)&work1, &lwork, info); + if (*info < 0) + return CV_HAL_ERROR_NOT_IMPLEMENTED; + lwork = cvRound(work1); //optimal buffer size std::vector workBufMemHolder(lwork + 1); fptype* buffer = &workBufMemHolder.front(); @@ -312,6 +323,9 @@ lapack_QR(fptype* a, size_t a_step, int m, int n, int k, fptype* b, size_t b_ste else if (typeid(fptype) == typeid(double)) dgels_(mode, &m, &n, &k, (double*)tmpA, &ldtmpA, (double*)tmpB, &m, (double*)&work1, &lwork, info); + if (*info < 0) + return CV_HAL_ERROR_NOT_IMPLEMENTED; + lwork = cvRound(work1); //optimal buffer size std::vector workBufMemHolder(lwork + 1); fptype* buffer = &workBufMemHolder.front(); @@ -331,6 +345,9 @@ lapack_QR(fptype* a, size_t a_step, int m, int n, int k, fptype* b, size_t b_ste else if (typeid(fptype) == typeid(double)) dgeqrf_(&m, &n, (double*)tmpA, &ldtmpA, (double*)dst, (double*)&work1, &lwork, info); + if (*info < 0) + return CV_HAL_ERROR_NOT_IMPLEMENTED; + lwork = cvRound(work1); //optimal buffer size std::vector workBufMemHolder(lwork + 1); fptype* buffer = &workBufMemHolder.front(); @@ -538,19 +555,17 @@ int lapack_Cholesky64f(double* a, size_t a_step, int m, double* b, size_t b_step int lapack_SVD32f(float* a, size_t a_step, float *w, float* u, size_t u_step, float* vt, size_t v_step, int m, int n, int flags) { - - if(m < HAL_SVD_SMALL_MATRIX_THRESH) + if(m < HAL_SVD_SMALL_MATRIX_THRESH || n <= 0) return CV_HAL_ERROR_NOT_IMPLEMENTED; - int info; + int info = 0; return lapack_SVD(a, a_step, w, u, u_step, vt, v_step, m, n, flags, &info); } int lapack_SVD64f(double* a, size_t a_step, double *w, double* u, size_t u_step, double* vt, size_t v_step, int m, int n, int flags) { - - if(m < HAL_SVD_SMALL_MATRIX_THRESH) + if(m < HAL_SVD_SMALL_MATRIX_THRESH || n <= 0) return CV_HAL_ERROR_NOT_IMPLEMENTED; - int info; + int info = 0; return lapack_SVD(a, a_step, w, u, u_step, vt, v_step, m, n, flags, &info); } diff --git a/modules/core/test/test_math.cpp b/modules/core/test/test_math.cpp index 066475b19e..0b9469ee83 100644 --- a/modules/core/test/test_math.cpp +++ b/modules/core/test/test_math.cpp @@ -698,6 +698,11 @@ void Core_GEMMTest::get_minmax_bounds( int /*i*/, int /*j*/, int /*type*/, Scala void Core_GEMMTest::run_func() { + /*printf("tabc_flags=At:%d,Bt:%d,Ct:%d; A(%d x %d), B(%d x %d), C(%d x %d)\n", + (tabc_flag & GEMM_1_T) != 0, (tabc_flag & GEMM_2_T) != 0, (tabc_flag & GEMM_3_T) != 0, + test_mat[INPUT][0].rows, test_mat[INPUT][0].cols, + test_mat[INPUT][1].rows, test_mat[INPUT][1].cols, + test_mat[INPUT][4].rows, test_mat[INPUT][4].cols);*/ cvGEMM( test_array[INPUT][0], test_array[INPUT][1], alpha, test_array[INPUT][4], beta, test_array[OUTPUT][0], tabc_flag ); }