diff --git a/lapack-netlib/SRC/DEPRECATED/cgegs.c b/lapack-netlib/SRC/DEPRECATED/cgegs.c new file mode 100644 index 000000000..53ce73bc1 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/cgegs.c @@ -0,0 +1,998 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CGEGS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, */ +/* VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, */ +/* INFO ) */ + +/* CHARACTER JOBVSL, JOBVSR */ +/* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N */ +/* REAL RWORK( * ) */ +/* COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CGGES. */ +/* > */ +/* > CGEGS computes the eigenvalues, Schur form, and, optionally, the */ +/* > left and or/right Schur vectors of a complex matrix pair (A,B). */ +/* > Given two square matrices A and B, the generalized Schur */ +/* > factorization has the form */ +/* > */ +/* > A = Q*S*Z**H, B = Q*T*Z**H */ +/* > */ +/* > where Q and Z are unitary matrices and S and T are upper triangular. */ +/* > The columns of Q are the left Schur vectors */ +/* > and the columns of Z are the right Schur vectors. */ +/* > */ +/* > If only the eigenvalues of (A,B) are needed, the driver routine */ +/* > CGEGV should be used instead. See CGEGV for a description of the */ +/* > eigenvalues of the generalized nonsymmetric eigenvalue problem */ +/* > (GNEP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVSL */ +/* > \verbatim */ +/* > JOBVSL is CHARACTER*1 */ +/* > = 'N': do not compute the left Schur vectors; */ +/* > = 'V': compute the left Schur vectors (returned in VSL). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVSR */ +/* > \verbatim */ +/* > JOBVSR is CHARACTER*1 */ +/* > = 'N': do not compute the right Schur vectors; */ +/* > = 'V': compute the right Schur vectors (returned in VSR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VSL, and VSR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA, N) */ +/* > On entry, the matrix A. */ +/* > On exit, the upper triangular matrix S from the generalized */ +/* > Schur factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB, N) */ +/* > On entry, the matrix B. */ +/* > On exit, the upper triangular matrix T from the generalized */ +/* > Schur factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX array, dimension (N) */ +/* > The complex scalars alpha that define the eigenvalues of */ +/* > GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur */ +/* > form of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX array, dimension (N) */ +/* > The non-negative real scalars beta that define the */ +/* > eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element */ +/* > of the triangular factor T. */ +/* > */ +/* > Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */ +/* > represent the j-th eigenvalue of the matrix pair (A,B), in */ +/* > one of the forms lambda = alpha/beta or mu = beta/alpha. */ +/* > Since either lambda or mu may overflow, they should not, */ +/* > in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSL */ +/* > \verbatim */ +/* > VSL is COMPLEX array, dimension (LDVSL,N) */ +/* > If JOBVSL = 'V', the matrix of left Schur vectors Q. */ +/* > Not referenced if JOBVSL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSL */ +/* > \verbatim */ +/* > LDVSL is INTEGER */ +/* > The leading dimension of the matrix VSL. LDVSL >= 1, and */ +/* > if JOBVSL = 'V', LDVSL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSR */ +/* > \verbatim */ +/* > VSR is COMPLEX array, dimension (LDVSR,N) */ +/* > If JOBVSR = 'V', the matrix of right Schur vectors Z. */ +/* > Not referenced if JOBVSR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSR */ +/* > \verbatim */ +/* > LDVSR is INTEGER */ +/* > The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* > if JOBVSR = 'V', LDVSR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX 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 >= f2cmax(1,2*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > To compute the optimal value of LWORK, call ILAENV to get */ +/* > blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute: */ +/* > NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR; */ +/* > the optimal LWORK is N*(NB+1). */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL 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. */ +/* > =1,...,N: */ +/* > The QZ iteration failed. (A,B) are not in Schur */ +/* > form, but ALPHA(j) and BETA(j) should be correct for */ +/* > j=INFO+1,...,N. */ +/* > > N: errors that usually indicate LAPACK problems: */ +/* > =N+1: error return from CGGBAL */ +/* > =N+2: error return from CGEQRF */ +/* > =N+3: error return from CUNMQR */ +/* > =N+4: error return from CUNGQR */ +/* > =N+5: error return from CGGHRD */ +/* > =N+6: error return from CHGEQZ (other than failed */ +/* > iteration) */ +/* > =N+7: error return from CGGBAK (computing VSL) */ +/* > =N+8: error return from CGGBAK (computing VSR) */ +/* > =N+9: error return from CLASCL (various places) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexGEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int cgegs_(char *jobvsl, char *jobvsr, integer *n, complex * + a, integer *lda, complex *b, integer *ldb, complex *alpha, complex * + beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr, + complex *work, integer *lwork, real *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2, i__3; + + /* Local variables */ + real anrm, bnrm; + integer itau, lopt; + extern logical lsame_(char *, char *); + integer ileft, iinfo, icols; + logical ilvsl; + integer iwork; + logical ilvsr; + integer irows; + extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, complex *, integer *, + integer *), cggbal_(char *, integer *, complex *, + integer *, complex *, integer *, integer *, integer *, real *, + real *, real *, integer *); + integer nb; + extern real clange_(char *, integer *, integer *, complex *, integer *, + real *); + extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, integer *), + clascl_(char *, integer *, integer *, real *, real *, integer *, + integer *, complex *, integer *, integer *); + logical ilascl, ilbscl; + extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *, + integer *, complex *, complex *, integer *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), claset_(char *, + integer *, integer *, complex *, complex *, complex *, integer *); + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + real bignum; + extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *, + integer *, integer *, complex *, integer *, complex *, integer *, + complex *, complex *, complex *, integer *, complex *, integer *, + complex *, integer *, real *, integer *); + integer ijobvl, iright, ijobvr; + real anrmto; + integer lwkmin, nb1, nb2, nb3; + real bnrmto; + extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *, integer *), + cunmqr_(char *, char *, integer *, integer *, integer *, complex + *, integer *, complex *, complex *, integer *, complex *, integer + *, integer *); + real smlnum; + integer irwork, lwkopt; + logical lquery; + integer ihi, ilo; + real eps; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1 * 1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1 * 1; + vsr -= vsr_offset; + --work; + --rwork; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = FALSE_; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = TRUE_; + } else { + ijobvl = -1; + ilvsl = FALSE_; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = FALSE_; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = TRUE_; + } else { + ijobvr = -1; + ilvsr = FALSE_; + } + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 1; + lwkmin = f2cmax(i__1,1); + lwkopt = lwkmin; + work[1].r = (real) lwkopt, work[1].i = 0.f; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -11; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -13; + } else if (*lwork < lwkmin && ! lquery) { + *info = -15; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "CUNMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "CUNGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); + lopt = *n * (nb + 1); + work[1].r = (real) lopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CGEGS ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = slamch_("E") * slamch_("B"); + safmin = slamch_("S"); + smlnum = *n * safmin / eps; + bignum = 1.f / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]); + ilascl = FALSE_; + if (anrm > 0.f && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + + if (ilascl) { + clascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]); + ilbscl = FALSE_; + if (bnrm > 0.f && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + + if (ilbscl) { + clascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ + + ileft = 1; + iright = *n + 1; + irwork = iright + *n; + iwork = 1; + cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[ + ileft], &rwork[iright], &rwork[irwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L10; + } + +/* Reduce B to triangular form, and initialize VSL and/or VSR */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwork; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L10; + } + + i__1 = *lwork + 1 - iwork; + cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L10; + } + + if (ilvsl) { + claset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl); + i__1 = irows - 1; + i__2 = irows - 1; + clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo + + 1 + ilo * vsl_dim1], ldvsl); + i__1 = *lwork + 1 - iwork; + cungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L10; + } + } + + if (ilvsr) { + claset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ + + cgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 5; + goto L10; + } + +/* Perform QZ algorithm, computing Schur vectors if desired */ + + iwork = itau; + i__1 = *lwork + 1 - iwork; + chgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, & + vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &rwork[irwork], & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L10; + } + +/* Apply permutation to VSL and VSR */ + + if (ilvsl) { + cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, & + vsl[vsl_offset], ldvsl, &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L10; + } + } + if (ilvsr) { + cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, & + vsr[vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L10; + } + } + +/* Undo scaling */ + + if (ilascl) { + clascl_("U", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + clascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alpha[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + + if (ilbscl) { + clascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + clascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +L10: + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CGEGS */ + +} /* cgegs_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/cgegv.c b/lapack-netlib/SRC/DEPRECATED/cgegv.c new file mode 100644 index 000000000..714acd702 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/cgegv.c @@ -0,0 +1,1231 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CGEGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, */ +/* VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) */ + +/* CHARACTER JOBVL, JOBVR */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N */ +/* REAL RWORK( * ) */ +/* COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CGGEV. */ +/* > */ +/* > CGEGV computes the eigenvalues and, optionally, the left and/or right */ +/* > eigenvectors of a complex matrix pair (A,B). */ +/* > Given two square matrices A and B, */ +/* > the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */ +/* > eigenvalues lambda and corresponding (non-zero) eigenvectors x such */ +/* > that */ +/* > A*x = lambda*B*x. */ +/* > */ +/* > An alternate form is to find the eigenvalues mu and corresponding */ +/* > eigenvectors y such that */ +/* > mu*A*y = B*y. */ +/* > */ +/* > These two forms are equivalent with mu = 1/lambda and x = y if */ +/* > neither lambda nor mu is zero. In order to deal with the case that */ +/* > lambda or mu is zero or small, two values alpha and beta are returned */ +/* > for each eigenvalue, such that lambda = alpha/beta and */ +/* > mu = beta/alpha. */ +/* > */ +/* > The vectors x and y in the above equations are right eigenvectors of */ +/* > the matrix pair (A,B). Vectors u and v satisfying */ +/* > u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */ +/* > are left eigenvectors of (A,B). */ +/* > */ +/* > Note: this routine performs "full balancing" on A and B */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': do not compute the left generalized eigenvectors; */ +/* > = 'V': compute the left generalized eigenvectors (returned */ +/* > in VL). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': do not compute the right generalized eigenvectors; */ +/* > = 'V': compute the right generalized eigenvectors (returned */ +/* > in VR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VL, and VR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA, N) */ +/* > On entry, the matrix A. */ +/* > If JOBVL = 'V' or JOBVR = 'V', then on exit A */ +/* > contains the Schur form of A from the generalized Schur */ +/* > factorization of the pair (A,B) after balancing. If no */ +/* > eigenvectors were computed, then only the diagonal elements */ +/* > of the Schur form will be correct. See CGGHRD and CHGEQZ */ +/* > for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB, N) */ +/* > On entry, the matrix B. */ +/* > If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */ +/* > upper triangular matrix obtained from B in the generalized */ +/* > Schur factorization of the pair (A,B) after balancing. */ +/* > If no eigenvectors were computed, then only the diagonal */ +/* > elements of B will be correct. See CGGHRD and CHGEQZ for */ +/* > details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX array, dimension (N) */ +/* > The complex scalars alpha that define the eigenvalues of */ +/* > GNEP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX array, dimension (N) */ +/* > The complex scalars beta that define the eigenvalues of GNEP. */ +/* > */ +/* > Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */ +/* > represent the j-th eigenvalue of the matrix pair (A,B), in */ +/* > one of the forms lambda = alpha/beta or mu = beta/alpha. */ +/* > Since either lambda or mu may overflow, they should not, */ +/* > in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is COMPLEX array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored */ +/* > in the columns of VL, in the same order as their eigenvalues. */ +/* > Each eigenvector is scaled so that its largest component has */ +/* > abs(real part) + abs(imag. part) = 1, except for eigenvectors */ +/* > corresponding to an eigenvalue with alpha = beta = 0, which */ +/* > are set to zero. */ +/* > Not referenced if JOBVL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the matrix VL. LDVL >= 1, and */ +/* > if JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is COMPLEX array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors x(j) are stored */ +/* > in the columns of VR, in the same order as their eigenvalues. */ +/* > Each eigenvector is scaled so that its largest component has */ +/* > abs(real part) + abs(imag. part) = 1, except for eigenvectors */ +/* > corresponding to an eigenvalue with alpha = beta = 0, which */ +/* > are set to zero. */ +/* > Not referenced if JOBVR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the matrix VR. LDVR >= 1, and */ +/* > if JOBVR = 'V', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX 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 >= f2cmax(1,2*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > To compute the optimal value of LWORK, call ILAENV to get */ +/* > blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute: */ +/* > NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR; */ +/* > The optimal LWORK is MAX( 2*N, N*(NB+1) ). */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL 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. */ +/* > =1,...,N: */ +/* > The QZ iteration failed. No eigenvectors have been */ +/* > calculated, but ALPHA(j) and BETA(j) should be */ +/* > correct for j=INFO+1,...,N. */ +/* > > N: errors that usually indicate LAPACK problems: */ +/* > =N+1: error return from CGGBAL */ +/* > =N+2: error return from CGEQRF */ +/* > =N+3: error return from CUNMQR */ +/* > =N+4: error return from CUNGQR */ +/* > =N+5: error return from CGGHRD */ +/* > =N+6: error return from CHGEQZ (other than failed */ +/* > iteration) */ +/* > =N+7: error return from CTGEVC */ +/* > =N+8: error return from CGGBAK (computing VL) */ +/* > =N+9: error return from CGGBAK (computing VR) */ +/* > =N+10: error return from CLASCL (various calls) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexGEeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Balancing */ +/* > --------- */ +/* > */ +/* > This driver calls CGGBAL to both permute and scale rows and columns */ +/* > of A and B. The permutations PL and PR are chosen so that PL*A*PR */ +/* > and PL*B*R will be upper triangular except for the diagonal blocks */ +/* > A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */ +/* > possible. The diagonal scaling matrices DL and DR are chosen so */ +/* > that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */ +/* > one (except for the elements that start out zero.) */ +/* > */ +/* > After the eigenvalues and eigenvectors of the balanced matrices */ +/* > have been computed, CGGBAK transforms the eigenvectors back to what */ +/* > they would have been (in perfect arithmetic) if they had not been */ +/* > balanced. */ +/* > */ +/* > Contents of A and B on Exit */ +/* > -------- -- - --- - -- ---- */ +/* > */ +/* > If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */ +/* > both), then on exit the arrays A and B will contain the complex Schur */ +/* > form[*] of the "balanced" versions of A and B. If no eigenvectors */ +/* > are computed, then only the diagonal blocks will be correct. */ +/* > */ +/* > [*] In other words, upper triangular form. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cgegv_(char *jobvl, char *jobvr, integer *n, complex *a, + integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, + complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex * + work, integer *lwork, real *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2, i__3, i__4; + real r__1, r__2, r__3, r__4; + complex q__1, q__2; + + /* Local variables */ + real absb, anrm, bnrm; + integer itau; + real temp; + logical ilvl, ilvr; + integer lopt; + real anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta; + extern logical lsame_(char *, char *); + integer ileft, iinfo, icols, iwork, irows, jc; + extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, complex *, integer *, + integer *), cggbal_(char *, integer *, complex *, + integer *, complex *, integer *, integer *, integer *, real *, + real *, real *, integer *); + integer nb, in; + extern real clange_(char *, integer *, integer *, complex *, integer *, + real *); + integer jr; + extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, complex *, integer *, integer *); + real salfai; + extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, complex *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer *, + complex *, complex *, integer *, integer *); + real salfar; + extern real slamch_(char *); + extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex + *, integer *, complex *, integer *), claset_(char *, + integer *, integer *, complex *, complex *, complex *, integer *); + real safmin; + extern /* Subroutine */ int ctgevc_(char *, char *, logical *, integer *, + complex *, integer *, complex *, integer *, complex *, integer *, + complex *, integer *, integer *, integer *, complex *, real *, + integer *); + real safmax; + char chtemp[1]; + logical ldumma[1]; + extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *, + integer *, integer *, complex *, integer *, complex *, integer *, + complex *, complex *, complex *, integer *, complex *, integer *, + complex *, integer *, real *, integer *), + xerbla_(char *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ijobvl, iright; + logical ilimit; + integer ijobvr; + extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *, integer *); + integer lwkmin, nb1, nb2, nb3; + extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *, integer *); + integer irwork, lwkopt; + logical lquery; + integer ihi, ilo; + real eps; + logical ilv; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + --rwork; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = FALSE_; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = TRUE_; + } else { + ijobvl = -1; + ilvl = FALSE_; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = FALSE_; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = TRUE_; + } else { + ijobvr = -1; + ilvr = FALSE_; + } + ilv = ilvl || ilvr; + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 1; + lwkmin = f2cmax(i__1,1); + lwkopt = lwkmin; + work[1].r = (real) lwkopt, work[1].i = 0.f; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -11; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -13; + } else if (*lwork < lwkmin && ! lquery) { + *info = -15; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "CUNMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "CUNGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); +/* Computing MAX */ + i__1 = *n << 1, i__2 = *n * (nb + 1); + lopt = f2cmax(i__1,i__2); + work[1].r = (real) lopt, work[1].i = 0.f; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CGEGV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = slamch_("E") * slamch_("B"); + safmin = slamch_("S"); + safmin += safmin; + safmax = 1.f / safmin; + +/* Scale A */ + + anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]); + anrm1 = anrm; + anrm2 = 1.f; + if (anrm < 1.f) { + if (safmax * anrm < 1.f) { + anrm1 = safmin; + anrm2 = safmax * anrm; + } + } + + if (anrm > 0.f) { + clascl_("G", &c_n1, &c_n1, &anrm, &c_b29, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Scale B */ + + bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]); + bnrm1 = bnrm; + bnrm2 = 1.f; + if (bnrm < 1.f) { + if (safmax * bnrm < 1.f) { + bnrm1 = safmin; + bnrm2 = safmax * bnrm; + } + } + + if (bnrm > 0.f) { + clascl_("G", &c_n1, &c_n1, &bnrm, &c_b29, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ +/* Also "balance" the matrix. */ + + ileft = 1; + iright = *n + 1; + irwork = iright + *n; + cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[ + ileft], &rwork[iright], &rwork[irwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L80; + } + +/* Reduce B to triangular form, and initialize VL and/or VR */ + + irows = ihi + 1 - ilo; + if (ilv) { + icols = *n + 1 - ilo; + } else { + icols = irows; + } + itau = 1; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L80; + } + + i__1 = *lwork + 1 - iwork; + cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L80; + } + + if (ilvl) { + claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl); + i__1 = irows - 1; + i__2 = irows - 1; + clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo + + 1 + ilo * vl_dim1], ldvl); + i__1 = *lwork + 1 - iwork; + cungqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ + itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L80; + } + } + + if (ilvr) { + claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr); + } + +/* Reduce to generalized Hessenberg form */ + + if (ilv) { + +/* Eigenvectors requested -- work on whole matrix. */ + + cgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo); + } else { + cgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, + &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &iinfo); + } + if (iinfo != 0) { + *info = *n + 5; + goto L80; + } + +/* Perform QZ algorithm */ + + iwork = itau; + if (ilv) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + i__1 = *lwork + 1 - iwork; + chgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &work[iwork], &i__1, &rwork[irwork], &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L80; + } + + if (ilv) { + +/* Compute Eigenvectors */ + + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + + ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, + &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ + iwork], &rwork[irwork], &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L80; + } + +/* Undo balancing on VL and VR, rescale */ + + if (ilvl) { + cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, + &vl[vl_offset], ldvl, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L80; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + temp = 0.f; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + i__3 = jr + jc * vl_dim1; + r__3 = temp, r__4 = (r__1 = vl[i__3].r, abs(r__1)) + ( + r__2 = r_imag(&vl[jr + jc * vl_dim1]), abs(r__2)); + temp = f2cmax(r__3,r__4); +/* L10: */ + } + if (temp < safmin) { + goto L30; + } + temp = 1.f / temp; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + i__3 = jr + jc * vl_dim1; + i__4 = jr + jc * vl_dim1; + q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i; + vl[i__3].r = q__1.r, vl[i__3].i = q__1.i; +/* L20: */ + } +L30: + ; + } + } + if (ilvr) { + cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, + &vr[vr_offset], ldvr, &iinfo); + if (iinfo != 0) { + *info = *n + 9; + goto L80; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + temp = 0.f; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + i__3 = jr + jc * vr_dim1; + r__3 = temp, r__4 = (r__1 = vr[i__3].r, abs(r__1)) + ( + r__2 = r_imag(&vr[jr + jc * vr_dim1]), abs(r__2)); + temp = f2cmax(r__3,r__4); +/* L40: */ + } + if (temp < safmin) { + goto L60; + } + temp = 1.f / temp; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + i__3 = jr + jc * vr_dim1; + i__4 = jr + jc * vr_dim1; + q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i; + vr[i__3].r = q__1.r, vr[i__3].i = q__1.i; +/* L50: */ + } +L60: + ; + } + } + +/* End of eigenvector calculation */ + + } + +/* Undo scaling in alpha, beta */ + +/* Note: this does not give the alpha and beta for the unscaled */ +/* problem. */ + +/* Un-scaling is limited to avoid underflow in alpha and beta */ +/* if they are significant. */ + + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = jc; + absar = (r__1 = alpha[i__2].r, abs(r__1)); + absai = (r__1 = r_imag(&alpha[jc]), abs(r__1)); + i__2 = jc; + absb = (r__1 = beta[i__2].r, abs(r__1)); + i__2 = jc; + salfar = anrm * alpha[i__2].r; + salfai = anrm * r_imag(&alpha[jc]); + i__2 = jc; + sbeta = bnrm * beta[i__2].r; + ilimit = FALSE_; + scale = 1.f; + +/* Check for significant underflow in imaginary part of ALPHA */ + +/* Computing MAX */ + r__1 = safmin, r__2 = eps * absar, r__1 = f2cmax(r__1,r__2), r__2 = eps * + absb; + if (abs(salfai) < safmin && absai >= f2cmax(r__1,r__2)) { + ilimit = TRUE_; +/* Computing MAX */ + r__1 = safmin, r__2 = anrm2 * absai; + scale = safmin / anrm1 / f2cmax(r__1,r__2); + } + +/* Check for significant underflow in real part of ALPHA */ + +/* Computing MAX */ + r__1 = safmin, r__2 = eps * absai, r__1 = f2cmax(r__1,r__2), r__2 = eps * + absb; + if (abs(salfar) < safmin && absar >= f2cmax(r__1,r__2)) { + ilimit = TRUE_; +/* Computing MAX */ +/* Computing MAX */ + r__3 = safmin, r__4 = anrm2 * absar; + r__1 = scale, r__2 = safmin / anrm1 / f2cmax(r__3,r__4); + scale = f2cmax(r__1,r__2); + } + +/* Check for significant underflow in BETA */ + +/* Computing MAX */ + r__1 = safmin, r__2 = eps * absar, r__1 = f2cmax(r__1,r__2), r__2 = eps * + absai; + if (abs(sbeta) < safmin && absb >= f2cmax(r__1,r__2)) { + ilimit = TRUE_; +/* Computing MAX */ +/* Computing MAX */ + r__3 = safmin, r__4 = bnrm2 * absb; + r__1 = scale, r__2 = safmin / bnrm1 / f2cmax(r__3,r__4); + scale = f2cmax(r__1,r__2); + } + +/* Check for possible overflow when limiting scaling */ + + if (ilimit) { +/* Computing MAX */ + r__1 = abs(salfar), r__2 = abs(salfai), r__1 = f2cmax(r__1,r__2), + r__2 = abs(sbeta); + temp = scale * safmin * f2cmax(r__1,r__2); + if (temp > 1.f) { + scale /= temp; + } + if (scale < 1.f) { + ilimit = FALSE_; + } + } + +/* Recompute un-scaled ALPHA, BETA if necessary. */ + + if (ilimit) { + i__2 = jc; + salfar = scale * alpha[i__2].r * anrm; + salfai = scale * r_imag(&alpha[jc]) * anrm; + i__2 = jc; + q__2.r = scale * beta[i__2].r, q__2.i = scale * beta[i__2].i; + q__1.r = bnrm * q__2.r, q__1.i = bnrm * q__2.i; + sbeta = q__1.r; + } + i__2 = jc; + q__1.r = salfar, q__1.i = salfai; + alpha[i__2].r = q__1.r, alpha[i__2].i = q__1.i; + i__2 = jc; + beta[i__2].r = sbeta, beta[i__2].i = 0.f; +/* L70: */ + } + +L80: + work[1].r = (real) lwkopt, work[1].i = 0.f; + + return 0; + +/* End of CGEGV */ + +} /* cgegv_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/cgelsx.c b/lapack-netlib/SRC/DEPRECATED/cgelsx.c new file mode 100644 index 000000000..854b2cd1f --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/cgelsx.c @@ -0,0 +1,907 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CGELSX solves overdetermined or underdetermined systems for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CGELSX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */ +/* WORK, RWORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, M, N, NRHS, RANK */ +/* REAL RCOND */ +/* INTEGER JPVT( * ) */ +/* REAL RWORK( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CGELSY. */ +/* > */ +/* > CGELSX computes the minimum-norm solution to a complex linear least */ +/* > squares problem: */ +/* > minimize || A * X - B || */ +/* > using a complete orthogonal factorization of A. A is an M-by-N */ +/* > matrix which may be rank-deficient. */ +/* > */ +/* > Several right hand side vectors b and solution vectors x can be */ +/* > handled in a single call; they are stored as the columns of the */ +/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* > matrix X. */ +/* > */ +/* > The routine first computes a QR factorization with column pivoting: */ +/* > A * P = Q * [ R11 R12 ] */ +/* > [ 0 R22 ] */ +/* > with R11 defined as the largest leading submatrix whose estimated */ +/* > condition number is less than 1/RCOND. The order of R11, RANK, */ +/* > is the effective rank of A. */ +/* > */ +/* > Then, R22 is considered to be negligible, and R12 is annihilated */ +/* > by unitary transformations from the right, arriving at the */ +/* > complete orthogonal factorization: */ +/* > A * P = Q * [ T11 0 ] * Z */ +/* > [ 0 0 ] */ +/* > The minimum-norm solution is then */ +/* > X = P * Z**H [ inv(T11)*Q1**H*B ] */ +/* > [ 0 ] */ +/* > where Q1 consists of the first RANK columns of Q. */ +/* > \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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of */ +/* > columns of matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A has been overwritten by details of its */ +/* > complete orthogonal factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,NRHS) */ +/* > On entry, the M-by-NRHS right hand side matrix B. */ +/* > On exit, the N-by-NRHS solution matrix X. */ +/* > If m >= n and RANK = n, the residual sum-of-squares for */ +/* > the solution in the i-th column is given by the sum of */ +/* > squares of elements N+1:M in that column. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is an */ +/* > initial column, otherwise it is a free column. Before */ +/* > the QR factorization of A, all initial columns are */ +/* > permuted to the leading positions; only the remaining */ +/* > free columns are moved as a result of column pivoting */ +/* > during the factorization. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > RCOND is used to determine the effective rank of A, which */ +/* > is defined as the order of the largest leading triangular */ +/* > submatrix R11 in the QR factorization with pivoting of A, */ +/* > whose estimated condition number < 1/RCOND. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The effective rank of A, i.e., the order of the submatrix */ +/* > R11. This is the same as the order of the submatrix T11 */ +/* > in the complete orthogonal factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (f2cmin(M,N) + f2cmax( N, 2*f2cmin(M,N)+NRHS )), */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (2*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 complexGEsolve */ + +/* ===================================================================== */ +/* Subroutine */ int cgelsx_(integer *m, integer *n, integer *nrhs, complex * + a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond, + integer *rank, complex *work, real *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + complex q__1; + + /* Local variables */ + real anrm, bnrm, smin, smax; + integer i__, j, k, iascl, ibscl, ismin, ismax; + complex c1, c2; + extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *), claic1_(integer *, + integer *, complex *, real *, complex *, complex *, real *, + complex *, complex *); + complex s1, s2, t1, t2; + extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *), slabad_(real *, real *); + extern real clange_(char *, integer *, integer *, complex *, integer *, + real *); + integer mn; + extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, complex *, integer *, integer *), cgeqpf_(integer *, integer *, complex *, integer *, + integer *, complex *, complex *, real *, integer *); + extern real slamch_(char *); + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *), xerbla_(char *, + integer *); + real bignum; + extern /* Subroutine */ int clatzm_(char *, integer *, integer *, complex + *, integer *, complex *, complex *, complex *, integer *, complex + *); + real sminpr; + extern /* Subroutine */ int ctzrqf_(integer *, integer *, complex *, + integer *, complex *, integer *); + real smaxpr, smlnum; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --jpvt; + --work; + --rwork; + + /* Function Body */ + mn = f2cmin(*m,*n); + ismin = mn + 1; + ismax = (mn << 1) + 1; + +/* Test the input arguments. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*m); + if (*ldb < f2cmax(i__1,*n)) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CGELSX", &i__1); + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*nrhs) == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + smlnum = slamch_("S") / slamch_("P"); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + +/* Scale A, B if f2cmax elements outside range [SMLNUM,BIGNUM] */ + + anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]); + iascl = 0; + if (anrm > 0.f && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.f) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = f2cmax(*m,*n); + claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + *rank = 0; + goto L100; + } + + bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]); + ibscl = 0; + if (bnrm > 0.f && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Compute QR factorization with column pivoting of A: */ +/* A * P = Q * R */ + + cgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], & + rwork[1], info); + +/* complex workspace MN+N. Real workspace 2*N. Details of Householder */ +/* rotations stored in WORK(1:MN). */ + +/* Determine RANK using incremental condition estimation */ + + i__1 = ismin; + work[i__1].r = 1.f, work[i__1].i = 0.f; + i__1 = ismax; + work[i__1].r = 1.f, work[i__1].i = 0.f; + smax = c_abs(&a[a_dim1 + 1]); + smin = smax; + if (c_abs(&a[a_dim1 + 1]) == 0.f) { + *rank = 0; + i__1 = f2cmax(*m,*n); + claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + goto L100; + } else { + *rank = 1; + } + +L10: + if (*rank < mn) { + i__ = *rank + 1; + claic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &sminpr, &s1, &c1); + claic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &smaxpr, &s2, &c2); + + if (smaxpr * *rcond <= sminpr) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ismin + i__ - 1; + i__3 = ismin + i__ - 1; + q__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, q__1.i = + s1.r * work[i__3].i + s1.i * work[i__3].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; + i__2 = ismax + i__ - 1; + i__3 = ismax + i__ - 1; + q__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, q__1.i = + s2.r * work[i__3].i + s2.i * work[i__3].r; + work[i__2].r = q__1.r, work[i__2].i = q__1.i; +/* L20: */ + } + i__1 = ismin + *rank; + work[i__1].r = c1.r, work[i__1].i = c1.i; + i__1 = ismax + *rank; + work[i__1].r = c2.r, work[i__1].i = c2.i; + smin = sminpr; + smax = smaxpr; + ++(*rank); + goto L10; + } + } + +/* Logically partition R = [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* where R11 = R(1:RANK,1:RANK) */ + +/* [R11,R12] = [ T11, 0 ] * Y */ + + if (*rank < *n) { + ctzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info); + } + +/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ + +/* B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS) */ + + cunm2r_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, & + work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], info); + +/* workspace NRHS */ + +/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ + + ctrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[ + a_offset], lda, &b[b_offset], ldb); + + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Y**H * B(1:N,1:NRHS) */ + + if (*rank < *n) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - *rank + 1; + r_cnjg(&q__1, &work[mn + i__]); + clatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, + &q__1, &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], ldb, & + work[(mn << 1) + 1]); +/* L50: */ + } + } + +/* workspace NRHS */ + +/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = (mn << 1) + i__; + work[i__3].r = 1.f, work[i__3].i = 0.f; +/* L60: */ + } + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = (mn << 1) + i__; + if (work[i__3].r == 1.f && work[i__3].i == 0.f) { + if (jpvt[i__] != i__) { + k = i__; + i__3 = k + j * b_dim1; + t1.r = b[i__3].r, t1.i = b[i__3].i; + i__3 = jpvt[k] + j * b_dim1; + t2.r = b[i__3].r, t2.i = b[i__3].i; +L70: + i__3 = jpvt[k] + j * b_dim1; + b[i__3].r = t1.r, b[i__3].i = t1.i; + i__3 = (mn << 1) + k; + work[i__3].r = 0.f, work[i__3].i = 0.f; + t1.r = t2.r, t1.i = t2.i; + k = jpvt[k]; + i__3 = jpvt[k] + j * b_dim1; + t2.r = b[i__3].r, t2.i = b[i__3].i; + if (jpvt[k] != i__) { + goto L70; + } + i__3 = i__ + j * b_dim1; + b[i__3].r = t1.r, b[i__3].i = t1.i; + i__3 = (mn << 1) + k; + work[i__3].r = 0.f, work[i__3].i = 0.f; + } + } +/* L80: */ + } +/* L90: */ + } + +/* Undo scaling */ + + if (iascl == 1) { + clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + clascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], + lda, info); + } else if (iascl == 2) { + clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + clascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], + lda, info); + } + if (ibscl == 1) { + clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L100: + + return 0; + +/* End of CGELSX */ + +} /* cgelsx_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/cgeqpf.c b/lapack-netlib/SRC/DEPRECATED/cgeqpf.c new file mode 100644 index 000000000..d3e9c5488 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/cgeqpf.c @@ -0,0 +1,743 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CGEQPF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CGEQPF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* INTEGER JPVT( * ) */ +/* REAL RWORK( * ) */ +/* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CGEQP3. */ +/* > */ +/* > CGEQPF computes a QR factorization with column pivoting of a */ +/* > complex M-by-N matrix A: A*P = Q*R. */ +/* > \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 COMPLEX array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the upper triangle of the array contains the */ +/* > f2cmin(M,N)-by-N upper triangular matrix R; the elements */ +/* > below the diagonal, together with the array TAU, */ +/* > represent the unitary matrix Q as a product of */ +/* > f2cmin(m,n) elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */ +/* > to the front of A*P (a leading column); if JPVT(i) = 0, */ +/* > the i-th column of A is a free column. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (2*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 complexGEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(n) */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex 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). */ +/* > */ +/* > The matrix P is represented in jpvt as follows: If */ +/* > jpvt(j) = i */ +/* > then the jth column of P is the ith canonical unit vector. */ +/* > */ +/* > Partial column norm updating strategy modified by */ +/* > Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* > University of Zagreb, Croatia. */ +/* > -- April 2011 -- */ +/* > For more details see LAPACK Working Note 176. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cgeqpf_(integer *m, integer *n, complex *a, integer *lda, + integer *jpvt, complex *tau, complex *work, real *rwork, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1, r__2; + complex q__1; + + /* Local variables */ + real temp, temp2; + integer i__, j; + real tol3z; + extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * + , integer *, complex *, complex *, integer *, complex *), + cswap_(integer *, complex *, integer *, complex *, integer *); + integer itemp; + extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *, + integer *, complex *, complex *, integer *); + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + complex *, integer *); + integer ma, mn; + extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, + integer *, complex *); + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + extern integer isamax_(integer *, real *, integer *); + complex aii; + integer pvt; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --jpvt; + --tau; + --work; + --rwork; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CGEQPF", &i__1); + return 0; + } + + mn = f2cmin(*m,*n); + tol3z = sqrt(slamch_("Epsilon")); + +/* Move initial columns up front */ + + itemp = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (jpvt[i__] != 0) { + if (i__ != itemp) { + cswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1], + &c__1); + jpvt[i__] = jpvt[itemp]; + jpvt[itemp] = i__; + } else { + jpvt[i__] = i__; + } + ++itemp; + } else { + jpvt[i__] = i__; + } +/* L10: */ + } + --itemp; + +/* Compute the QR factorization and update remaining columns */ + + if (itemp > 0) { + ma = f2cmin(itemp,*m); + cgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info); + if (ma < *n) { + i__1 = *n - ma; + cunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset] + , lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], + info); + } + } + + if (itemp < mn) { + +/* Initialize partial column norms. The first n elements of */ +/* work store the exact column norms. */ + + i__1 = *n; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + i__2 = *m - itemp; + rwork[i__] = scnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1); + rwork[*n + i__] = rwork[i__]; +/* L20: */ + } + +/* Compute factorization */ + + i__1 = mn; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + +/* Determine ith pivot column and swap if necessary */ + + i__2 = *n - i__ + 1; + pvt = i__ - 1 + isamax_(&i__2, &rwork[i__], &c__1); + + if (pvt != i__) { + cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[i__]; + jpvt[i__] = itemp; + rwork[pvt] = rwork[i__]; + rwork[*n + pvt] = rwork[*n + i__]; + } + +/* Generate elementary reflector H(i) */ + + i__2 = i__ + i__ * a_dim1; + aii.r = a[i__2].r, aii.i = a[i__2].i; + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + clarfg_(&i__2, &aii, &a[f2cmin(i__3,*m) + i__ * a_dim1], &c__1, &tau[ + i__]); + i__2 = i__ + i__ * a_dim1; + a[i__2].r = aii.r, a[i__2].i = aii.i; + + if (i__ < *n) { + +/* Apply H(i) to A(i:m,i+1:n) from the left */ + + i__2 = i__ + i__ * a_dim1; + aii.r = a[i__2].r, aii.i = a[i__2].i; + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + r_cnjg(&q__1, &tau[i__]); + clarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & + q__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); + i__2 = i__ + i__ * a_dim1; + a[i__2].r = aii.r, a[i__2].i = aii.i; + } + +/* Update partial column norms */ + + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (rwork[j] != 0.f) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = c_abs(&a[i__ + j * a_dim1]) / rwork[j]; +/* Computing MAX */ + r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp); + temp = f2cmax(r__1,r__2); +/* Computing 2nd power */ + r__1 = rwork[j] / rwork[*n + j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + if (*m - i__ > 0) { + i__3 = *m - i__; + rwork[j] = scnrm2_(&i__3, &a[i__ + 1 + j * a_dim1] + , &c__1); + rwork[*n + j] = rwork[j]; + } else { + rwork[j] = 0.f; + rwork[*n + j] = 0.f; + } + } else { + rwork[j] *= sqrt(temp); + } + } +/* L30: */ + } + +/* L40: */ + } + } + return 0; + +/* End of CGEQPF */ + +} /* cgeqpf_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/cggsvd.c b/lapack-netlib/SRC/DEPRECATED/cggsvd.c new file mode 100644 index 000000000..0b9ae8637 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/cggsvd.c @@ -0,0 +1,889 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief CGGSVD computes the singular value decomposition (SVD) for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CGGSVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */ +/* LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */ +/* RWORK, IWORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */ +/* INTEGER IWORK( * ) */ +/* REAL ALPHA( * ), BETA( * ), RWORK( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ U( LDU, * ), V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CGGSVD3. */ +/* > */ +/* > CGGSVD computes the generalized singular value decomposition (GSVD) */ +/* > of an M-by-N complex matrix A and P-by-N complex matrix B: */ +/* > */ +/* > U**H*A*Q = D1*( 0 R ), V**H*B*Q = D2*( 0 R ) */ +/* > */ +/* > where U, V and Q are unitary matrices. */ +/* > Let K+L = the effective numerical rank of the */ +/* > matrix (A**H,B**H)**H, then R is a (K+L)-by-(K+L) nonsingular upper */ +/* > triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal" */ +/* > matrices and of the following structures, respectively: */ +/* > */ +/* > If M-K-L >= 0, */ +/* > */ +/* > K L */ +/* > D1 = K ( I 0 ) */ +/* > L ( 0 C ) */ +/* > M-K-L ( 0 0 ) */ +/* > */ +/* > K L */ +/* > D2 = L ( 0 S ) */ +/* > P-L ( 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > ( 0 R ) = K ( 0 R11 R12 ) */ +/* > L ( 0 0 R22 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* > S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R is stored in A(1:K+L,N-K-L+1:N) on exit. */ +/* > */ +/* > If M-K-L < 0, */ +/* > */ +/* > K M-K K+L-M */ +/* > D1 = K ( I 0 0 ) */ +/* > M-K ( 0 C 0 ) */ +/* > */ +/* > K M-K K+L-M */ +/* > D2 = M-K ( 0 S 0 ) */ +/* > K+L-M ( 0 0 I ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K M-K K+L-M */ +/* > ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* > M-K ( 0 0 R22 R23 ) */ +/* > K+L-M ( 0 0 0 R33 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* > S = diag( BETA(K+1), ... , BETA(M) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */ +/* > ( 0 R22 R23 ) */ +/* > in B(M-K+1:L,N+M-K-L+1:N) on exit. */ +/* > */ +/* > The routine computes C, S, R, and optionally the unitary */ +/* > transformation matrices U, V and Q. */ +/* > */ +/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */ +/* > A and B implicitly gives the SVD of A*inv(B): */ +/* > A*inv(B) = U*(D1*inv(D2))*V**H. */ +/* > If ( A**H,B**H)**H has orthnormal columns, then the GSVD of A and B is also */ +/* > equal to the CS decomposition of A and B. Furthermore, the GSVD can */ +/* > be used to derive the solution of the eigenvalue problem: */ +/* > A**H*A x = lambda* B**H*B x. */ +/* > In some literature, the GSVD of A and B is presented in the form */ +/* > U**H*A*X = ( 0 D1 ), V**H*B*X = ( 0 D2 ) */ +/* > where U and V are orthogonal and X is nonsingular, and D1 and D2 are */ +/* > ``diagonal''. The former GSVD form can be converted to the latter */ +/* > form by taking the nonsingular matrix X as */ +/* > */ +/* > X = Q*( I 0 ) */ +/* > ( 0 inv(R) ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Unitary matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Unitary matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Unitary matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \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 matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose. */ +/* > K + L = effective numerical rank of (A**H,B**H)**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular matrix R, or part of R. */ +/* > See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains part of the triangular matrix R if */ +/* > M-K-L < 0. See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is REAL array, dimension (N) */ +/* > */ +/* > On exit, ALPHA and BETA contain the generalized singular */ +/* > value pairs of A and B; */ +/* > ALPHA(1:K) = 1, */ +/* > BETA(1:K) = 0, */ +/* > and if M-K-L >= 0, */ +/* > ALPHA(K+1:K+L) = C, */ +/* > BETA(K+1:K+L) = S, */ +/* > or if M-K-L < 0, */ +/* > ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */ +/* > BETA(K+1:M) =S, BETA(M+1:K+L) =1 */ +/* > and */ +/* > ALPHA(K+L+1:N) = 0 */ +/* > BETA(K+L+1:N) = 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is COMPLEX array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the M-by-M unitary matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the P-by-P unitary matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (f2cmax(3*N,M,P)+N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > On exit, IWORK stores the sorting information. More */ +/* > precisely, the following loop will sort ALPHA */ +/* > for I = K+1, f2cmin(M,K+L) */ +/* > swap ALPHA(I) and ALPHA(IWORK(I)) */ +/* > endfor */ +/* > such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(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, the Jacobi-type procedure failed to */ +/* > converge. For further details, see subroutine CTGSJA. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLA REAL */ +/* > TOLB REAL */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > rank of (A**H,B**H)**H. Generally, they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MACHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERsing */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cggsvd_(char *jobu, char *jobv, char *jobq, integer *m, + integer *n, integer *p, integer *k, integer *l, complex *a, integer * + lda, complex *b, integer *ldb, real *alpha, real *beta, complex *u, + integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, + complex *work, real *rwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2; + + /* Local variables */ + integer ibnd; + real tola; + integer isub; + real tolb, unfl, temp, smax; + integer ncallmycycle, i__, j; + extern logical lsame_(char *, char *); + real anorm, bnorm; + logical wantq; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + logical wantu, wantv; + extern real clange_(char *, integer *, integer *, complex *, integer *, + real *), slamch_(char *); + extern /* Subroutine */ int ctgsja_(char *, char *, char *, integer *, + integer *, integer *, integer *, integer *, complex *, integer *, + complex *, integer *, real *, real *, real *, real *, complex *, + integer *, complex *, integer *, complex *, integer *, complex *, + integer *, integer *), xerbla_(char *, + integer *), cggsvp_(char *, char *, char *, integer *, + integer *, integer *, complex *, integer *, complex *, integer *, + real *, real *, integer *, integer *, complex *, integer *, + complex *, integer *, complex *, integer *, integer *, real *, + complex *, complex *, integer *); + real ulp; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + --rwork; + --iwork; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*p < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -10; + } else if (*ldb < f2cmax(1,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CGGSVD", &i__1); + return 0; + } + +/* Compute the Frobenius norm of matrices A and B */ + + anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]); + bnorm = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]); + +/* Get machine precision and set up threshold for determining */ +/* the effective numerical rank of the matrices A and B. */ + + ulp = slamch_("Precision"); + unfl = slamch_("Safe Minimum"); + tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp; + tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp; + + cggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, & + tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[ + q_offset], ldq, &iwork[1], &rwork[1], &work[1], &work[*n + 1], + info); + +/* Compute the GSVD of two upper "triangular" matrices */ + + ctgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], + ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[ + v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info); + +/* Sort the singular values and store the pivot indices in IWORK */ +/* Copy ALPHA to RWORK, then sort ALPHA in RWORK */ + + scopy_(n, &alpha[1], &c__1, &rwork[1], &c__1); +/* Computing MIN */ + i__1 = *l, i__2 = *m - *k; + ibnd = f2cmin(i__1,i__2); + i__1 = ibnd; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for largest ALPHA(K+I) */ + + isub = i__; + smax = rwork[*k + i__]; + i__2 = ibnd; + for (j = i__ + 1; j <= i__2; ++j) { + temp = rwork[*k + j]; + if (temp > smax) { + isub = j; + smax = temp; + } +/* L10: */ + } + if (isub != i__) { + rwork[*k + isub] = rwork[*k + i__]; + rwork[*k + i__] = smax; + iwork[*k + i__] = *k + isub; + } else { + iwork[*k + i__] = *k + i__; + } +/* L20: */ + } + + return 0; + +/* End of CGGSVD */ + +} /* cggsvd_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/cggsvp.c b/lapack-netlib/SRC/DEPRECATED/cggsvp.c new file mode 100644 index 000000000..25b28df74 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/cggsvp.c @@ -0,0 +1,1009 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CGGSVP */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CGGSVP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, */ +/* TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, */ +/* IWORK, RWORK, TAU, WORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */ +/* REAL TOLA, TOLB */ +/* INTEGER IWORK( * ) */ +/* REAL RWORK( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CGGSVP3. */ +/* > */ +/* > CGGSVP computes unitary matrices U, V and Q such that */ +/* > */ +/* > N-K-L K L */ +/* > U**H*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* > L ( 0 0 A23 ) */ +/* > M-K-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* > M-K ( 0 0 A23 ) */ +/* > */ +/* > N-K-L K L */ +/* > V**H*B*Q = L ( 0 0 B13 ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* > otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */ +/* > numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. */ +/* > */ +/* > This decomposition is the preprocessing step for computing the */ +/* > Generalized Singular Value Decomposition (GSVD), see subroutine */ +/* > CGGSVD. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Unitary matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Unitary matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Unitary matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular (or trapezoidal) matrix */ +/* > described in the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains the triangular matrix described in */ +/* > the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLA */ +/* > \verbatim */ +/* > TOLA is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLB */ +/* > \verbatim */ +/* > TOLB is REAL */ +/* > */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > numerical rank of matrix B and a subblock of A. Generally, */ +/* > they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MACHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose section. */ +/* > K + L = effective numerical rank of (A**H,B**H)**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is COMPLEX array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the unitary matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the unitary matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the unitary matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (f2cmax(3*N,M,P)) */ +/* > \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 complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > The subroutine uses LAPACK subroutine CGEQPF for the QR factorization */ +/* > with column pivoting to detect the effective numerical rank of the */ +/* > a matrix. It may be replaced by a better rank determination strategy. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int cggsvp_(char *jobu, char *jobv, char *jobq, integer *m, + integer *p, integer *n, complex *a, integer *lda, complex *b, integer + *ldb, real *tola, real *tolb, integer *k, integer *l, complex *u, + integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, + integer *iwork, real *rwork, complex *tau, complex *work, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + logical wantq, wantu, wantv; + extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *, + integer *, complex *, complex *, integer *), cgerq2_(integer *, + integer *, complex *, integer *, complex *, complex *, integer *), + cung2r_(integer *, integer *, integer *, complex *, integer *, + complex *, complex *, integer *), cunm2r_(char *, char *, integer + *, integer *, integer *, complex *, integer *, complex *, complex + *, integer *, complex *, integer *), cunmr2_(char + *, char *, integer *, integer *, integer *, complex *, integer *, + complex *, complex *, integer *, complex *, integer *), cgeqpf_(integer *, integer *, complex *, integer *, + integer *, complex *, complex *, real *, integer *), clacpy_(char + *, integer *, integer *, complex *, integer *, complex *, integer + *), claset_(char *, integer *, integer *, complex *, + complex *, complex *, integer *), xerbla_(char *, integer + *), clapmt_(logical *, integer *, integer *, complex *, + integer *, integer *); + logical forwrd; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --iwork; + --rwork; + --tau; + --work; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + forwrd = TRUE_; + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -8; + } else if (*ldb < f2cmax(1,*p)) { + *info = -10; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CGGSVP", &i__1); + return 0; + } + +/* QR with column pivoting of B: B*P = V*( S11 S12 ) */ +/* ( 0 0 ) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + cgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1], + info); + +/* Update A := A*P */ + + clapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); + +/* Determine the effective rank of matrix B. */ + + *l = 0; + i__1 = f2cmin(*p,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * b_dim1; + if ((r__1 = b[i__2].r, abs(r__1)) + (r__2 = r_imag(&b[i__ + i__ * + b_dim1]), abs(r__2)) > *tolb) { + ++(*l); + } +/* L20: */ + } + + if (wantv) { + +/* Copy the details of V, and form V. */ + + claset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv); + if (*p > 1) { + i__1 = *p - 1; + clacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], + ldv); + } + i__1 = f2cmin(*p,*n); + cung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); + } + +/* Clean up B */ + + i__1 = *l - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; +/* L30: */ + } +/* L40: */ + } + if (*p > *l) { + i__1 = *p - *l; + claset_("Full", &i__1, n, &c_b1, &c_b1, &b[*l + 1 + b_dim1], ldb); + } + + if (wantq) { + +/* Set Q = I and Update Q := Q*P */ + + claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); + clapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); + } + + if (*p >= *l && *n != *l) { + +/* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */ + + cgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); + +/* Update A := A*Z**H */ + + cunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, & + tau[1], &a[a_offset], lda, &work[1], info); + if (wantq) { + +/* Update Q := Q*Z**H */ + + cunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset], + ldb, &tau[1], &q[q_offset], ldq, &work[1], info); + } + +/* Clean up B */ + + i__1 = *n - *l; + claset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb); + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; +/* L50: */ + } +/* L60: */ + } + + } + +/* Let N-L L */ +/* A = ( A11 A12 ) M, */ + +/* then the following does the complete QR decomposition of A11: */ + +/* A11 = U*( 0 T12 )*P1**H */ +/* ( 0 0 ) */ + + i__1 = *n - *l; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L70: */ + } + i__1 = *n - *l; + cgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[ + 1], info); + +/* Determine the effective rank of A11 */ + + *k = 0; +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + if ((r__1 = a[i__2].r, abs(r__1)) + (r__2 = r_imag(&a[i__ + i__ * + a_dim1]), abs(r__2)) > *tola) { + ++(*k); + } +/* L80: */ + } + +/* Update A12 := U**H*A12, where A12 = A( 1:M, N-L+1:N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + cunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, & + tau[1], &a[(*n - *l + 1) * a_dim1 + 1], lda, &work[1], info); + + if (wantu) { + +/* Copy the details of U, and form U */ + + claset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu); + if (*m > 1) { + i__1 = *m - 1; + i__2 = *n - *l; + clacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] + , ldu); + } +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + cung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); + } + + if (wantq) { + +/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ + + i__1 = *n - *l; + clapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); + } + +/* Clean up A: set the strictly lower triangular part of */ +/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L90: */ + } +/* L100: */ + } + if (*m > *k) { + i__1 = *m - *k; + i__2 = *n - *l; + claset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a[*k + 1 + a_dim1], lda); + } + + if (*n - *l > *k) { + +/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ + + i__1 = *n - *l; + cgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); + + if (wantq) { + +/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**H */ + + i__1 = *n - *l; + cunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset], + lda, &tau[1], &q[q_offset], ldq, &work[1], info); + } + +/* Clean up A */ + + i__1 = *n - *l - *k; + claset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda); + i__1 = *n - *l; + for (j = *n - *l - *k + 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L110: */ + } +/* L120: */ + } + + } + + if (*m > *k) { + +/* QR factorization of A( K+1:M,N-L+1:N ) */ + + i__1 = *m - *k; + cgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & + work[1], info); + + if (wantu) { + +/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ + + i__1 = *m - *k; +/* Computing MIN */ + i__3 = *m - *k; + i__2 = f2cmin(i__3,*l); + cunm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n + - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + + 1], ldu, &work[1], info); + } + +/* Clean up */ + + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L130: */ + } +/* L140: */ + } + + } + + return 0; + +/* End of CGGSVP */ + +} /* cggsvp_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/clahrd.c b/lapack-netlib/SRC/DEPRECATED/clahrd.c new file mode 100644 index 000000000..eeed208f5 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/clahrd.c @@ -0,0 +1,734 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below th +e k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformati +on to the unreduced part of A. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLAHRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */ + +/* INTEGER K, LDA, LDT, LDY, N, NB */ +/* COMPLEX A( LDA, * ), T( LDT, NB ), TAU( NB ), */ +/* $ Y( LDY, NB ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CLAHR2. */ +/* > */ +/* > CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) */ +/* > matrix A so that elements below the k-th subdiagonal are zero. The */ +/* > reduction is performed by a unitary similarity transformation */ +/* > Q**H * A * Q. The routine returns the matrices V and T which determine */ +/* > Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. */ +/* > \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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of columns to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX 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 >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX 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 COMPLEX 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 >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \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**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex 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**H) * (A - Y*V**H). */ +/* > */ +/* > The contents of A on exit are illustrated by the following example */ +/* > with n = 7, k = 3 and nb = 2: */ +/* > */ +/* > ( a h a a a ) */ +/* > ( a h a a a ) */ +/* > ( a h 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). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int clahrd_(integer *n, integer *k, integer *nb, complex *a, + integer *lda, complex *tau, complex *t, integer *ldt, complex *y, + integer *ldy) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + complex q__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *), cgemv_(char *, integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, complex *, + integer *), ccopy_(integer *, complex *, integer *, + complex *, integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *), ctrmv_(char *, char *, char *, + integer *, complex *, integer *, complex *, integer *); + complex ei; + extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, + integer *, complex *), clacgv_(integer *, complex *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + 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(1:n,i) */ + +/* Compute i-th column of A - Y * V**H */ + + i__2 = i__ - 1; + clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda); + i__2 = i__ - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &a[*k + + i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], & + c__1); + i__2 = i__ - 1; + clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda); + +/* Apply I - V * T**H * V**H 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**H * b1 */ + + i__2 = i__ - 1; + ccopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + ctrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 + + a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1); + +/* w := w + V2**H *b2 */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, & + t[*nb * t_dim1 + 1], &c__1); + +/* w := T**H *w */ + + i__2 = i__ - 1; + ctrmv_("Upper", "Conjugate 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; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__2, &i__3, &q__1, &a[*k + i__ + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ + + i__ * a_dim1], &c__1); + +/* b1 := b1 - V1*w */ + + i__2 = i__ - 1; + ctrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1] + , lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + q__1.r = -1.f, q__1.i = 0.f; + caxpy_(&i__2, &q__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ + * a_dim1], &c__1); + + i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1; + a[i__2].r = ei.r, a[i__2].i = ei.i; + } + +/* Generate the elementary reflector H(i) to annihilate */ +/* A(k+i+1:n,i) */ + + i__2 = *k + i__ + i__ * a_dim1; + ei.r = a[i__2].r, ei.i = a[i__2].i; + i__2 = *n - *k - i__ + 1; +/* Computing MIN */ + i__3 = *k + i__ + 1; + clarfg_(&i__2, &ei, &a[f2cmin(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__]) + ; + i__2 = *k + i__ + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + +/* Compute Y(1:n,i) */ + + i__2 = *n - *k - i__ + 1; + cgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ * + y_dim1 + 1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[ + i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &t[i__ * + t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1); + cscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1); + +/* Compute T(1:i,i) */ + + i__2 = i__ - 1; + i__3 = i__; + q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; + cscal_(&i__2, &q__1, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[i__ * t_dim1 + 1], &c__1) + ; + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + +/* L10: */ + } + i__1 = *k + *nb + *nb * a_dim1; + a[i__1].r = ei.r, a[i__1].i = ei.i; + + return 0; + +/* End of CLAHRD */ + +} /* clahrd_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/clatzm.c b/lapack-netlib/SRC/DEPRECATED/clatzm.c new file mode 100644 index 000000000..b37e458bd --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/clatzm.c @@ -0,0 +1,629 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATZM */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CLATZM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER INCV, LDC, M, N */ +/* COMPLEX TAU */ +/* COMPLEX C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CUNMRZ. */ +/* > */ +/* > CLATZM applies a Householder matrix generated by CTZRQF to a matrix. */ +/* > */ +/* > Let P = I - tau*u*u**H, u = ( 1 ), */ +/* > ( v ) */ +/* > where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */ +/* > SIDE = 'R'. */ +/* > */ +/* > If SIDE equals 'L', let */ +/* > C = [ C1 ] 1 */ +/* > [ C2 ] m-1 */ +/* > n */ +/* > Then C is overwritten by P*C. */ +/* > */ +/* > If SIDE equals 'R', let */ +/* > C = [ C1, C2 ] m */ +/* > 1 n-1 */ +/* > Then C is overwritten by C*P. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form P * C */ +/* > = 'R': form C * P */ +/* > \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 COMPLEX array, dimension */ +/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */ +/* > (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ +/* > The vector v in the representation of P. 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 COMPLEX */ +/* > The value tau in the representation of P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C1 */ +/* > \verbatim */ +/* > C1 is COMPLEX array, dimension */ +/* > (LDC,N) if SIDE = 'L' */ +/* > (M,1) if SIDE = 'R' */ +/* > On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */ +/* > if SIDE = 'R'. */ +/* > */ +/* > On exit, the first row of P*C if SIDE = 'L', or the first */ +/* > column of C*P if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C2 */ +/* > \verbatim */ +/* > C2 is COMPLEX array, dimension */ +/* > (LDC, N) if SIDE = 'L' */ +/* > (LDC, N-1) if SIDE = 'R' */ +/* > On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */ +/* > m x (n - 1) matrix C2 if SIDE = 'R'. */ +/* > */ +/* > On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the arrays C1 and C2. */ +/* > LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > (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 complexOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int clatzm_(char *side, integer *m, integer *n, complex *v, + integer *incv, complex *tau, complex *c1, complex *c2, integer *ldc, + complex *work) +{ + /* System generated locals */ + integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1; + complex q__1; + + /* Local variables */ + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *), + cgemv_(char *, integer *, integer *, complex *, complex *, + integer *, complex *, integer *, complex *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgeru_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *), + ccopy_(integer *, complex *, integer *, complex *, integer *), + caxpy_(integer *, complex *, complex *, integer *, complex *, + integer *), clacgv_(integer *, complex *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c2_dim1 = *ldc; + c2_offset = 1 + c2_dim1 * 1; + c2 -= c2_offset; + c1_dim1 = *ldc; + c1_offset = 1 + c1_dim1 * 1; + c1 -= c1_offset; + --work; + + /* Function Body */ + if (f2cmin(*m,*n) == 0 || tau->r == 0.f && tau->i == 0.f) { + return 0; + } + + if (lsame_(side, "L")) { + +/* w := ( C1 + v**H * C2 )**H */ + + ccopy_(n, &c1[c1_offset], ldc, &work[1], &c__1); + clacgv_(n, &work[1], &c__1); + i__1 = *m - 1; + cgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, & + v[1], incv, &c_b1, &work[1], &c__1); + +/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w**H */ +/* [ C2 ] [ C2 ] [ v ] */ + + clacgv_(n, &work[1], &c__1); + q__1.r = -tau->r, q__1.i = -tau->i; + caxpy_(n, &q__1, &work[1], &c__1, &c1[c1_offset], ldc); + i__1 = *m - 1; + q__1.r = -tau->r, q__1.i = -tau->i; + cgeru_(&i__1, n, &q__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], + ldc); + + } else if (lsame_(side, "R")) { + +/* w := C1 + C2 * v */ + + ccopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1); + i__1 = *n - 1; + cgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1], + incv, &c_b1, &work[1], &c__1); + +/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**H] */ + + q__1.r = -tau->r, q__1.i = -tau->i; + caxpy_(m, &q__1, &work[1], &c__1, &c1[c1_offset], &c__1); + i__1 = *n - 1; + q__1.r = -tau->r, q__1.i = -tau->i; + cgerc_(m, &i__1, &q__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], + ldc); + } + + return 0; + +/* End of CLATZM */ + +} /* clatzm_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/ctzrqf.c b/lapack-netlib/SRC/DEPRECATED/ctzrqf.c new file mode 100644 index 000000000..9441fc4a3 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/ctzrqf.c @@ -0,0 +1,661 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CTZRQF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download CTZRQF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* COMPLEX A( LDA, * ), TAU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine CTZRZF. */ +/* > */ +/* > CTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */ +/* > to upper triangular form by means of unitary transformations. */ +/* > */ +/* > The upper trapezoidal matrix A is factored as */ +/* > */ +/* > A = ( R 0 ) * Z, */ +/* > */ +/* > where Z is an N-by-N unitary matrix and R is an M-by-M upper */ +/* > triangular matrix. */ +/* > \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 >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the leading M-by-N upper trapezoidal part of the */ +/* > array A must contain the matrix to be factorized. */ +/* > On exit, the leading M-by-M upper triangular part of A */ +/* > contains the upper triangular matrix R, and elements M+1 to */ +/* > N of the first M rows of A, with the array TAU, represent the */ +/* > unitary matrix Z as a product of M elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX array, dimension (M) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \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 complexOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The factorization is obtained by Householder's method. The kth */ +/* > transformation matrix, Z( k ), whose conjugate transpose is used to */ +/* > introduce zeros into the (m - k + 1)th row of A, is given in the form */ +/* > */ +/* > Z( k ) = ( I 0 ), */ +/* > ( 0 T( k ) ) */ +/* > */ +/* > where */ +/* > */ +/* > T( k ) = I - tau*u( k )*u( k )**H, u( k ) = ( 1 ), */ +/* > ( 0 ) */ +/* > ( z( k ) ) */ +/* > */ +/* > tau is a scalar and z( k ) is an ( n - m ) element vector. */ +/* > tau and z( k ) are chosen to annihilate the elements of the kth row */ +/* > of X. */ +/* > */ +/* > The scalar tau is returned in the kth element of TAU and the vector */ +/* > u( k ) in the kth row of A, such that the elements of z( k ) are */ +/* > in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* > the upper triangular part of A. */ +/* > */ +/* > Z is given by */ +/* > */ +/* > Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ctzrqf_(integer *m, integer *n, complex *a, integer *lda, + complex *tau, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + complex q__1, q__2; + + /* Local variables */ + integer i__, k; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *); + complex alpha; + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), ccopy_(integer *, complex *, integer *, + complex *, integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + integer m1; + extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, + integer *, complex *), clacgv_(integer *, complex *, integer *), + xerbla_(char *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTZRQF", &i__1); + return 0; + } + +/* Perform the factorization. */ + + if (*m == 0) { + return 0; + } + if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; +/* L10: */ + } + } else { +/* Computing MIN */ + i__1 = *m + 1; + m1 = f2cmin(i__1,*n); + for (k = *m; k >= 1; --k) { + +/* Use a Householder reflection to zero the kth row of A. */ +/* First set up the reflection. */ + + i__1 = k + k * a_dim1; + r_cnjg(&q__1, &a[k + k * a_dim1]); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = *n - *m; + clacgv_(&i__1, &a[k + m1 * a_dim1], lda); + i__1 = k + k * a_dim1; + alpha.r = a[i__1].r, alpha.i = a[i__1].i; + i__1 = *n - *m + 1; + clarfg_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]); + i__1 = k + k * a_dim1; + a[i__1].r = alpha.r, a[i__1].i = alpha.i; + i__1 = k; + r_cnjg(&q__1, &tau[k]); + tau[i__1].r = q__1.r, tau[i__1].i = q__1.i; + + i__1 = k; + if ((tau[i__1].r != 0.f || tau[i__1].i != 0.f) && k > 1) { + +/* We now perform the operation A := A*P( k )**H. */ + +/* Use the first ( k - 1 ) elements of TAU to store a( k ), */ +/* where a( k ) consists of the first ( k - 1 ) elements of */ +/* the kth column of A. Also let B denote the first */ +/* ( k - 1 ) rows of the last ( n - m ) columns of A. */ + + i__1 = k - 1; + ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1); + +/* Form w = a( k ) + B*z( k ) in TAU. */ + + i__1 = k - 1; + i__2 = *n - *m; + cgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 + + 1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], & + c__1); + +/* Now form a( k ) := a( k ) - conjg(tau)*w */ +/* and B := B - conjg(tau)*w*z( k )**H. */ + + i__1 = k - 1; + r_cnjg(&q__2, &tau[k]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + caxpy_(&i__1, &q__1, &tau[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + i__1 = k - 1; + i__2 = *n - *m; + r_cnjg(&q__2, &tau[k]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + cgerc_(&i__1, &i__2, &q__1, &tau[1], &c__1, &a[k + m1 * + a_dim1], lda, &a[m1 * a_dim1 + 1], lda); + } +/* L20: */ + } + } + + return 0; + +/* End of CTZRQF */ + +} /* ctzrqf_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dgegs.c b/lapack-netlib/SRC/DEPRECATED/dgegs.c new file mode 100644 index 000000000..b8dc9cad5 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dgegs.c @@ -0,0 +1,1010 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGEGS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, */ +/* ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER JOBVSL, JOBVSR */ +/* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), */ +/* $ VSR( LDVSR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DGGES. */ +/* > */ +/* > DGEGS computes the eigenvalues, real Schur form, and, optionally, */ +/* > left and or/right Schur vectors of a real matrix pair (A,B). */ +/* > Given two square matrices A and B, the generalized real Schur */ +/* > factorization has the form */ +/* > */ +/* > A = Q*S*Z**T, B = Q*T*Z**T */ +/* > */ +/* > where Q and Z are orthogonal matrices, T is upper triangular, and S */ +/* > is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */ +/* > blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */ +/* > of eigenvalues of (A,B). The columns of Q are the left Schur vectors */ +/* > and the columns of Z are the right Schur vectors. */ +/* > */ +/* > If only the eigenvalues of (A,B) are needed, the driver routine */ +/* > DGEGV should be used instead. See DGEGV for a description of the */ +/* > eigenvalues of the generalized nonsymmetric eigenvalue problem */ +/* > (GNEP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVSL */ +/* > \verbatim */ +/* > JOBVSL is CHARACTER*1 */ +/* > = 'N': do not compute the left Schur vectors; */ +/* > = 'V': compute the left Schur vectors (returned in VSL). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVSR */ +/* > \verbatim */ +/* > JOBVSR is CHARACTER*1 */ +/* > = 'N': do not compute the right Schur vectors; */ +/* > = 'V': compute the right Schur vectors (returned in VSR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VSL, and VSR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the matrix A. */ +/* > On exit, the upper quasi-triangular matrix S from the */ +/* > generalized real Schur factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the matrix B. */ +/* > On exit, the upper triangular matrix T from the generalized */ +/* > real Schur factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > The real parts of each scalar alpha defining an eigenvalue */ +/* > of GNEP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > The imaginary parts of each scalar alpha defining an */ +/* > eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */ +/* > eigenvalue is real; if positive, then the j-th and (j+1)-st */ +/* > eigenvalues are a complex conjugate pair, with */ +/* > ALPHAI(j+1) = -ALPHAI(j). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > The scalars beta that define the eigenvalues of GNEP. */ +/* > Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ +/* > beta = BETA(j) represent the j-th eigenvalue of the matrix */ +/* > pair (A,B), in one of the forms lambda = alpha/beta or */ +/* > mu = beta/alpha. Since either lambda or mu may overflow, */ +/* > they should not, in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSL */ +/* > \verbatim */ +/* > VSL is DOUBLE PRECISION array, dimension (LDVSL,N) */ +/* > If JOBVSL = 'V', the matrix of left Schur vectors Q. */ +/* > Not referenced if JOBVSL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSL */ +/* > \verbatim */ +/* > LDVSL is INTEGER */ +/* > The leading dimension of the matrix VSL. LDVSL >=1, and */ +/* > if JOBVSL = 'V', LDVSL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSR */ +/* > \verbatim */ +/* > VSR is DOUBLE PRECISION array, dimension (LDVSR,N) */ +/* > If JOBVSR = 'V', the matrix of right Schur vectors Z. */ +/* > Not referenced if JOBVSR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSR */ +/* > \verbatim */ +/* > LDVSR is INTEGER */ +/* > The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* > if JOBVSR = 'V', LDVSR >= 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 >= f2cmax(1,4*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > To compute the optimal value of LWORK, call ILAENV to get */ +/* > blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */ +/* > NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR */ +/* > The optimal LWORK is 2*N + N*(NB+1). */ +/* > */ +/* > 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. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. (A,B) are not in Schur */ +/* > form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ +/* > be correct for j=INFO+1,...,N. */ +/* > > N: errors that usually indicate LAPACK problems: */ +/* > =N+1: error return from DGGBAL */ +/* > =N+2: error return from DGEQRF */ +/* > =N+3: error return from DORMQR */ +/* > =N+4: error return from DORGQR */ +/* > =N+5: error return from DGGHRD */ +/* > =N+6: error return from DHGEQZ (other than failed */ +/* > iteration) */ +/* > =N+7: error return from DGGBAK (computing VSL) */ +/* > =N+8: error return from DGGBAK (computing VSR) */ +/* > =N+9: error return from DLASCL (various places) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int dgegs_(char *jobvsl, char *jobvsr, integer *n, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + alphar, doublereal *alphai, doublereal *beta, doublereal *vsl, + integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2; + + /* Local variables */ + doublereal anrm, bnrm; + integer itau, lopt; + extern logical lsame_(char *, char *); + integer ileft, iinfo, icols; + logical ilvsl; + integer iwork; + logical ilvsr; + integer irows; + extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *); + integer nb; + extern /* Subroutine */ int dggbal_(char *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + logical ilascl, ilbscl; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + doublereal bignum; + extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *); + integer ijobvl, iright, ijobvr; + extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal anrmto; + integer lwkmin, nb1, nb2, nb3; + doublereal bnrmto; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + doublereal smlnum; + integer lwkopt; + logical lquery; + integer ihi, ilo; + doublereal eps; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1 * 1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1 * 1; + vsr -= vsr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = FALSE_; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = TRUE_; + } else { + ijobvl = -1; + ilvsl = FALSE_; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = FALSE_; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = TRUE_; + } else { + ijobvr = -1; + ilvsr = FALSE_; + } + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 2; + lwkmin = f2cmax(i__1,1); + lwkopt = lwkmin; + work[1] = (doublereal) lwkopt; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -12; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -14; + } else if (*lwork < lwkmin && ! lquery) { + *info = -16; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); + lopt = (*n << 1) + *n * (nb + 1); + work[1] = (doublereal) lopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEGS ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("E") * dlamch_("B"); + safmin = dlamch_("S"); + smlnum = *n * safmin / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = FALSE_; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + + if (ilascl) { + dlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = FALSE_; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + + if (ilbscl) { + dlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ +/* Workspace layout: (2*N words -- "work..." not actually used) */ +/* left_permutation, right_permutation, work... */ + + ileft = 1; + iright = *n + 1; + iwork = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L10; + } + +/* Reduce B to triangular form, and initialize VSL and/or VSR */ +/* Workspace layout: ("work..." must have at least N words) */ +/* left_permutation, right_permutation, tau, work... */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwork; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L10; + } + + i__1 = *lwork + 1 - iwork; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L10; + } + + if (ilvsl) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl); + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo + + 1 + ilo * vsl_dim1], ldvsl); + i__1 = *lwork + 1 - iwork; + dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L10; + } + } + + if (ilvsr) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ + + dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 5; + goto L10; + } + +/* Perform QZ algorithm, computing Schur vectors if desired */ +/* Workspace layout: ("work..." must have at least 1 word) */ +/* left_permutation, right_permutation, work... */ + + iwork = itau; + i__1 = *lwork + 1 - iwork; + dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] + , ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L10; + } + +/* Apply permutation to VSL and VSR */ + + if (ilvsl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ + vsl_offset], ldvsl, &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L10; + } + } + if (ilvsr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ + vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L10; + } + } + +/* Undo scaling */ + + if (ilascl) { + dlascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + + if (ilbscl) { + dlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + dlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +L10: + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DGEGS */ + +} /* dgegs_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dgegv.c b/lapack-netlib/SRC/DEPRECATED/dgegv.c new file mode 100644 index 000000000..42e6e7f9d --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dgegv.c @@ -0,0 +1,1304 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGEGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, */ +/* BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) */ + +/* CHARACTER JOBVL, JOBVR */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DGGEV. */ +/* > */ +/* > DGEGV computes the eigenvalues and, optionally, the left and/or right */ +/* > eigenvectors of a real matrix pair (A,B). */ +/* > Given two square matrices A and B, */ +/* > the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */ +/* > eigenvalues lambda and corresponding (non-zero) eigenvectors x such */ +/* > that */ +/* > */ +/* > A*x = lambda*B*x. */ +/* > */ +/* > An alternate form is to find the eigenvalues mu and corresponding */ +/* > eigenvectors y such that */ +/* > */ +/* > mu*A*y = B*y. */ +/* > */ +/* > These two forms are equivalent with mu = 1/lambda and x = y if */ +/* > neither lambda nor mu is zero. In order to deal with the case that */ +/* > lambda or mu is zero or small, two values alpha and beta are returned */ +/* > for each eigenvalue, such that lambda = alpha/beta and */ +/* > mu = beta/alpha. */ +/* > */ +/* > The vectors x and y in the above equations are right eigenvectors of */ +/* > the matrix pair (A,B). Vectors u and v satisfying */ +/* > */ +/* > u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */ +/* > */ +/* > are left eigenvectors of (A,B). */ +/* > */ +/* > Note: this routine performs "full balancing" on A and B */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': do not compute the left generalized eigenvectors; */ +/* > = 'V': compute the left generalized eigenvectors (returned */ +/* > in VL). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': do not compute the right generalized eigenvectors; */ +/* > = 'V': compute the right generalized eigenvectors (returned */ +/* > in VR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VL, and VR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the matrix A. */ +/* > If JOBVL = 'V' or JOBVR = 'V', then on exit A */ +/* > contains the real Schur form of A from the generalized Schur */ +/* > factorization of the pair (A,B) after balancing. */ +/* > If no eigenvectors were computed, then only the diagonal */ +/* > blocks from the Schur form will be correct. See DGGHRD and */ +/* > DHGEQZ for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, the matrix B. */ +/* > If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */ +/* > upper triangular matrix obtained from B in the generalized */ +/* > Schur factorization of the pair (A,B) after balancing. */ +/* > If no eigenvectors were computed, then only those elements of */ +/* > B corresponding to the diagonal blocks from the Schur form of */ +/* > A will be correct. See DGGHRD and DHGEQZ for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > The real parts of each scalar alpha defining an eigenvalue of */ +/* > GNEP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > The imaginary parts of each scalar alpha defining an */ +/* > eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */ +/* > eigenvalue is real; if positive, then the j-th and */ +/* > (j+1)-st eigenvalues are a complex conjugate pair, with */ +/* > ALPHAI(j+1) = -ALPHAI(j). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > The scalars beta that define the eigenvalues of GNEP. */ +/* > */ +/* > Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ +/* > beta = BETA(j) represent the j-th eigenvalue of the matrix */ +/* > pair (A,B), in one of the forms lambda = alpha/beta or */ +/* > mu = beta/alpha. Since either lambda or mu may overflow, */ +/* > they should not, in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored */ +/* > in the columns of VL, in the same order as their eigenvalues. */ +/* > If the j-th eigenvalue is real, then u(j) = VL(:,j). */ +/* > 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). */ +/* > */ +/* > Each eigenvector is scaled so that its largest component has */ +/* > abs(real part) + abs(imag. part) = 1, except for eigenvectors */ +/* > corresponding to an eigenvalue with alpha = beta = 0, which */ +/* > are set to zero. */ +/* > Not referenced if JOBVL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the matrix VL. LDVL >= 1, and */ +/* > if JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors x(j) are stored */ +/* > in the columns of VR, in the same order as their eigenvalues. */ +/* > If the j-th eigenvalue is real, then x(j) = VR(:,j). */ +/* > If the j-th and (j+1)-st eigenvalues form a complex conjugate */ +/* > pair, then */ +/* > x(j) = VR(:,j) + i*VR(:,j+1) */ +/* > and */ +/* > x(j+1) = VR(:,j) - i*VR(:,j+1). */ +/* > */ +/* > Each eigenvector is scaled so that its largest component has */ +/* > abs(real part) + abs(imag. part) = 1, except for eigenvalues */ +/* > corresponding to an eigenvalue with alpha = beta = 0, which */ +/* > are set to zero. */ +/* > Not referenced if JOBVR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the matrix VR. LDVR >= 1, and */ +/* > 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 >= f2cmax(1,8*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > To compute the optimal value of LWORK, call ILAENV to get */ +/* > blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */ +/* > NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR; */ +/* > The optimal LWORK is: */ +/* > 2*N + MAX( 6*N, N*(NB+1) ). */ +/* > */ +/* > 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. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. No eigenvectors have been */ +/* > calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ +/* > should be correct for j=INFO+1,...,N. */ +/* > > N: errors that usually indicate LAPACK problems: */ +/* > =N+1: error return from DGGBAL */ +/* > =N+2: error return from DGEQRF */ +/* > =N+3: error return from DORMQR */ +/* > =N+4: error return from DORGQR */ +/* > =N+5: error return from DGGHRD */ +/* > =N+6: error return from DHGEQZ (other than failed */ +/* > iteration) */ +/* > =N+7: error return from DTGEVC */ +/* > =N+8: error return from DGGBAK (computing VL) */ +/* > =N+9: error return from DGGBAK (computing VR) */ +/* > =N+10: error return from DLASCL (various calls) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGEeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Balancing */ +/* > --------- */ +/* > */ +/* > This driver calls DGGBAL to both permute and scale rows and columns */ +/* > of A and B. The permutations PL and PR are chosen so that PL*A*PR */ +/* > and PL*B*R will be upper triangular except for the diagonal blocks */ +/* > A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */ +/* > possible. The diagonal scaling matrices DL and DR are chosen so */ +/* > that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */ +/* > one (except for the elements that start out zero.) */ +/* > */ +/* > After the eigenvalues and eigenvectors of the balanced matrices */ +/* > have been computed, DGGBAK transforms the eigenvectors back to what */ +/* > they would have been (in perfect arithmetic) if they had not been */ +/* > balanced. */ +/* > */ +/* > Contents of A and B on Exit */ +/* > -------- -- - --- - -- ---- */ +/* > */ +/* > If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */ +/* > both), then on exit the arrays A and B will contain the real Schur */ +/* > form[*] of the "balanced" versions of A and B. If no eigenvectors */ +/* > are computed, then only the diagonal blocks will be correct. */ +/* > */ +/* > [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations", */ +/* > by Golub & van Loan, pub. by Johns Hopkins U. Press. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dgegv_(char *jobvl, char *jobvr, integer *n, doublereal * + a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, + doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, + doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal absb, anrm, bnrm; + integer itau; + doublereal temp; + logical ilvl, ilvr; + integer lopt; + doublereal anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta; + extern logical lsame_(char *, char *); + integer ileft, iinfo, icols, iwork, irows, jc; + extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *); + integer nb; + extern /* Subroutine */ int dggbal_(char *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + integer in; + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + integer jr; + doublereal salfai; + extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal + *, doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + doublereal salfar; + extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal safmin; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + doublereal safmax; + char chtemp[1]; + logical ldumma[1]; + extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), dtgevc_(char *, char *, + logical *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *), + xerbla_(char *, integer *); + integer ijobvl, iright; + logical ilimit; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ijobvr; + extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *); + doublereal onepls; + integer lwkmin, nb1, nb2, nb3; + extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer lwkopt; + logical lquery; + integer ihi, ilo; + doublereal eps; + logical ilv; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = FALSE_; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = TRUE_; + } else { + ijobvl = -1; + ilvl = FALSE_; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = FALSE_; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = TRUE_; + } else { + ijobvr = -1; + ilvr = FALSE_; + } + ilv = ilvl || ilvr; + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 3; + lwkmin = f2cmax(i__1,1); + lwkopt = lwkmin; + work[1] = (doublereal) lwkopt; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -12; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -14; + } else if (*lwork < lwkmin && ! lquery) { + *info = -16; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); +/* Computing MAX */ + i__1 = *n * 6, i__2 = *n * (nb + 1); + lopt = (*n << 1) + f2cmax(i__1,i__2); + work[1] = (doublereal) lopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEGV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("E") * dlamch_("B"); + safmin = dlamch_("S"); + safmin += safmin; + safmax = 1. / safmin; + onepls = eps * 4 + 1.; + +/* Scale A */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + anrm1 = anrm; + anrm2 = 1.; + if (anrm < 1.) { + if (safmax * anrm < 1.) { + anrm1 = safmin; + anrm2 = safmax * anrm; + } + } + + if (anrm > 0.) { + dlascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Scale B */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + bnrm1 = bnrm; + bnrm2 = 1.; + if (bnrm < 1.) { + if (safmax * bnrm < 1.) { + bnrm1 = safmin; + bnrm2 = safmax * bnrm; + } + } + + if (bnrm > 0.) { + dlascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ +/* Workspace layout: (8*N words -- "work" requires 6*N words) */ +/* left_permutation, right_permutation, work... */ + + ileft = 1; + iright = *n + 1; + iwork = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L120; + } + +/* Reduce B to triangular form, and initialize VL and/or VR */ +/* Workspace layout: ("work..." must have at least N words) */ +/* left_permutation, right_permutation, tau, work... */ + + irows = ihi + 1 - ilo; + if (ilv) { + icols = *n + 1 - ilo; + } else { + icols = irows; + } + itau = iwork; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L120; + } + + i__1 = *lwork + 1 - iwork; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L120; + } + + if (ilvl) { + dlaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl) + ; + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo + + 1 + ilo * vl_dim1], ldvl); + i__1 = *lwork + 1 - iwork; + dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ + itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L120; + } + } + + if (ilvr) { + dlaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr) + ; + } + +/* Reduce to generalized Hessenberg form */ + + if (ilv) { + +/* Eigenvectors requested -- work on whole matrix. */ + + dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo); + } else { + dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, + &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &iinfo); + } + if (iinfo != 0) { + *info = *n + 5; + goto L120; + } + +/* Perform QZ algorithm */ +/* Workspace layout: ("work..." must have at least 1 word) */ +/* left_permutation, right_permutation, work... */ + + iwork = itau; + if (ilv) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + i__1 = *lwork + 1 - iwork; + dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L120; + } + + if (ilv) { + +/* Compute Eigenvectors (DTGEVC requires 6*N words of workspace) */ + + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + + dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, + &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ + iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L120; + } + +/* Undo balancing on VL and VR, rescale */ + + if (ilvl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vl[vl_offset], ldvl, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L120; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L50; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L10: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)) + (d__2 = vl[jr + (jc + 1) * + vl_dim1], abs(d__2)); + temp = f2cmax(d__3,d__4); +/* L20: */ + } + } + if (temp < safmin) { + goto L50; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; +/* L30: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; + vl[jr + (jc + 1) * vl_dim1] *= temp; +/* L40: */ + } + } +L50: + ; + } + } + if (ilvr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vr[vr_offset], ldvr, &iinfo); + if (iinfo != 0) { + *info = *n + 9; + goto L120; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L100; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L60: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)) + (d__2 = vr[jr + (jc + 1) * + vr_dim1], abs(d__2)); + temp = f2cmax(d__3,d__4); +/* L70: */ + } + } + if (temp < safmin) { + goto L100; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; +/* L80: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; + vr[jr + (jc + 1) * vr_dim1] *= temp; +/* L90: */ + } + } +L100: + ; + } + } + +/* End of eigenvector calculation */ + + } + +/* Undo scaling in alpha, beta */ + +/* Note: this does not give the alpha and beta for the unscaled */ +/* problem. */ + +/* Un-scaling is limited to avoid underflow in alpha and beta */ +/* if they are significant. */ + + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + absar = (d__1 = alphar[jc], abs(d__1)); + absai = (d__1 = alphai[jc], abs(d__1)); + absb = (d__1 = beta[jc], abs(d__1)); + salfar = anrm * alphar[jc]; + salfai = anrm * alphai[jc]; + sbeta = bnrm * beta[jc]; + ilimit = FALSE_; + scale = 1.; + +/* Check for significant underflow in ALPHAI */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absar, d__1 = f2cmax(d__1,d__2), d__2 = eps * + absb; + if (abs(salfai) < safmin && absai >= f2cmax(d__1,d__2)) { + ilimit = TRUE_; +/* Computing MAX */ + d__1 = onepls * safmin, d__2 = anrm2 * absai; + scale = onepls * safmin / anrm1 / f2cmax(d__1,d__2); + + } else if (salfai == 0.) { + +/* If insignificant underflow in ALPHAI, then make the */ +/* conjugate eigenvalue real. */ + + if (alphai[jc] < 0. && jc > 1) { + alphai[jc - 1] = 0.; + } else if (alphai[jc] > 0. && jc < *n) { + alphai[jc + 1] = 0.; + } + } + +/* Check for significant underflow in ALPHAR */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absai, d__1 = f2cmax(d__1,d__2), d__2 = eps * + absb; + if (abs(salfar) < safmin && absar >= f2cmax(d__1,d__2)) { + ilimit = TRUE_; +/* Computing MAX */ +/* Computing MAX */ + d__3 = onepls * safmin, d__4 = anrm2 * absar; + d__1 = scale, d__2 = onepls * safmin / anrm1 / f2cmax(d__3,d__4); + scale = f2cmax(d__1,d__2); + } + +/* Check for significant underflow in BETA */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absar, d__1 = f2cmax(d__1,d__2), d__2 = eps * + absai; + if (abs(sbeta) < safmin && absb >= f2cmax(d__1,d__2)) { + ilimit = TRUE_; +/* Computing MAX */ +/* Computing MAX */ + d__3 = onepls * safmin, d__4 = bnrm2 * absb; + d__1 = scale, d__2 = onepls * safmin / bnrm1 / f2cmax(d__3,d__4); + scale = f2cmax(d__1,d__2); + } + +/* Check for possible overflow when limiting scaling */ + + if (ilimit) { +/* Computing MAX */ + d__1 = abs(salfar), d__2 = abs(salfai), d__1 = f2cmax(d__1,d__2), + d__2 = abs(sbeta); + temp = scale * safmin * f2cmax(d__1,d__2); + if (temp > 1.) { + scale /= temp; + } + if (scale < 1.) { + ilimit = FALSE_; + } + } + +/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */ + + if (ilimit) { + salfar = scale * alphar[jc] * anrm; + salfai = scale * alphai[jc] * anrm; + sbeta = scale * beta[jc] * bnrm; + } + alphar[jc] = salfar; + alphai[jc] = salfai; + beta[jc] = sbeta; +/* L110: */ + } + +L120: + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DGEGV */ + +} /* dgegv_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dgelsx.c b/lapack-netlib/SRC/DEPRECATED/dgelsx.c new file mode 100644 index 000000000..b470e83ec --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dgelsx.c @@ -0,0 +1,877 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGELSX solves overdetermined or underdetermined systems for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGELSX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */ +/* WORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, M, N, NRHS, RANK */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER JPVT( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DGELSY. */ +/* > */ +/* > DGELSX computes the minimum-norm solution to a real linear least */ +/* > squares problem: */ +/* > minimize || A * X - B || */ +/* > using a complete orthogonal factorization of A. A is an M-by-N */ +/* > matrix which may be rank-deficient. */ +/* > */ +/* > Several right hand side vectors b and solution vectors x can be */ +/* > handled in a single call; they are stored as the columns of the */ +/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* > matrix X. */ +/* > */ +/* > The routine first computes a QR factorization with column pivoting: */ +/* > A * P = Q * [ R11 R12 ] */ +/* > [ 0 R22 ] */ +/* > with R11 defined as the largest leading submatrix whose estimated */ +/* > condition number is less than 1/RCOND. The order of R11, RANK, */ +/* > is the effective rank of A. */ +/* > */ +/* > Then, R22 is considered to be negligible, and R12 is annihilated */ +/* > by orthogonal transformations from the right, arriving at the */ +/* > complete orthogonal factorization: */ +/* > A * P = Q * [ T11 0 ] * Z */ +/* > [ 0 0 ] */ +/* > The minimum-norm solution is then */ +/* > X = P * Z**T [ inv(T11)*Q1**T*B ] */ +/* > [ 0 ] */ +/* > where Q1 consists of the first RANK columns of Q. */ +/* > \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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of */ +/* > columns of matrices B and X. NRHS >= 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, A has been overwritten by details of its */ +/* > complete orthogonal factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the M-by-NRHS right hand side matrix B. */ +/* > On exit, the N-by-NRHS solution matrix X. */ +/* > If m >= n and RANK = n, the residual sum-of-squares for */ +/* > the solution in the i-th column is given by the sum of */ +/* > squares of elements N+1:M in that column. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is an */ +/* > initial column, otherwise it is a free column. Before */ +/* > the QR factorization of A, all initial columns are */ +/* > permuted to the leading positions; only the remaining */ +/* > free columns are moved as a result of column pivoting */ +/* > during the factorization. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > RCOND is used to determine the effective rank of A, which */ +/* > is defined as the order of the largest leading triangular */ +/* > submatrix R11 in the QR factorization with pivoting of A, */ +/* > whose estimated condition number < 1/RCOND. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The effective rank of A, i.e., the order of the submatrix */ +/* > R11. This is the same as the order of the submatrix T11 */ +/* > in the complete orthogonal factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension */ +/* > (f2cmax( f2cmin(M,N)+3*N, 2*f2cmin(M,N)+NRHS )), */ +/* > \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 doubleGEsolve */ + +/* ===================================================================== */ +/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * + jpvt, doublereal *rcond, integer *rank, doublereal *work, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal anrm, bnrm, smin, smax; + integer i__, j, k, iascl, ibscl, ismin, ismax; + doublereal c1, c2; + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dlaic1_( + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + doublereal s1, s2, t1, t2; + extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dlabad_( + doublereal *, doublereal *); + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + integer mn; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dgeqpf_(integer *, integer *, + doublereal *, integer *, integer *, doublereal *, doublereal *, + integer *), dlaset_(char *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *), xerbla_(char *, + integer *); + doublereal bignum; + extern /* Subroutine */ int dlatzm_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *); + doublereal sminpr, smaxpr, smlnum; + extern /* Subroutine */ int dtzrqf_(integer *, integer *, doublereal *, + integer *, doublereal *, integer *); + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --jpvt; + --work; + + /* Function Body */ + mn = f2cmin(*m,*n); + ismin = mn + 1; + ismax = (mn << 1) + 1; + +/* Test the input arguments. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*m); + if (*ldb < f2cmax(i__1,*n)) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGELSX", &i__1); + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*nrhs) == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S") / dlamch_("P"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A, B if f2cmax elements outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = f2cmax(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb); + *rank = 0; + goto L100; + } + + bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Compute QR factorization with column pivoting of A: */ +/* A * P = Q * R */ + + dgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info); + +/* workspace 3*N. Details of Householder rotations stored */ +/* in WORK(1:MN). */ + +/* Determine RANK using incremental condition estimation */ + + work[ismin] = 1.; + work[ismax] = 1.; + smax = (d__1 = a[a_dim1 + 1], abs(d__1)); + smin = smax; + if ((d__1 = a[a_dim1 + 1], abs(d__1)) == 0.) { + *rank = 0; + i__1 = f2cmax(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb); + goto L100; + } else { + *rank = 1; + } + +L10: + if (*rank < mn) { + i__ = *rank + 1; + dlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &sminpr, &s1, &c1); + dlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &smaxpr, &s2, &c2); + + if (smaxpr * *rcond <= sminpr) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1]; + work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1]; +/* L20: */ + } + work[ismin + *rank] = c1; + work[ismax + *rank] = c2; + smin = sminpr; + smax = smaxpr; + ++(*rank); + goto L10; + } + } + +/* Logically partition R = [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* where R11 = R(1:RANK,1:RANK) */ + +/* [R11,R12] = [ T11, 0 ] * Y */ + + if (*rank < *n) { + dtzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info); + } + +/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ + +/* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) */ + + dorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], & + b[b_offset], ldb, &work[(mn << 1) + 1], info); + +/* workspace NRHS */ + +/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ + + dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, & + a[a_offset], lda, &b[b_offset], ldb); + + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + b[i__ + j * b_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Y**T * B(1:N,1:NRHS) */ + + if (*rank < *n) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - *rank + 1; + dlatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, + &work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], + ldb, &work[(mn << 1) + 1]); +/* L50: */ + } + } + +/* workspace NRHS */ + +/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[(mn << 1) + i__] = 1.; +/* L60: */ + } + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[(mn << 1) + i__] == 1.) { + if (jpvt[i__] != i__) { + k = i__; + t1 = b[k + j * b_dim1]; + t2 = b[jpvt[k] + j * b_dim1]; +L70: + b[jpvt[k] + j * b_dim1] = t1; + work[(mn << 1) + k] = 0.; + t1 = t2; + k = jpvt[k]; + t2 = b[jpvt[k] + j * b_dim1]; + if (jpvt[k] != i__) { + goto L70; + } + b[i__ + j * b_dim1] = t1; + work[(mn << 1) + k] = 0.; + } + } +/* L80: */ + } +/* L90: */ + } + +/* Undo scaling */ + + if (iascl == 1) { + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], + lda, info); + } else if (iascl == 2) { + dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], + lda, info); + } + if (ibscl == 1) { + dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L100: + + return 0; + +/* End of DGELSX */ + +} /* dgelsx_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dgeqpf.c b/lapack-netlib/SRC/DEPRECATED/dgeqpf.c new file mode 100644 index 000000000..3eacd9dc5 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dgeqpf.c @@ -0,0 +1,732 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGEQPF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGEQPF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* INTEGER JPVT( * ) */ +/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DGEQP3. */ +/* > */ +/* > DGEQPF computes a QR factorization with column pivoting of a */ +/* > real M-by-N matrix A: A*P = Q*R. */ +/* > \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 upper triangle of the array contains the */ +/* > f2cmin(M,N)-by-N upper triangular matrix R; the elements */ +/* > below the diagonal, together with the array TAU, */ +/* > represent the orthogonal matrix Q as a product of */ +/* > f2cmin(m,n) elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */ +/* > to the front of A*P (a leading column); if JPVT(i) = 0, */ +/* > the i-th column of A is a free column. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION 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 */ +/* > \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 elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(n) */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H = 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). */ +/* > */ +/* > The matrix P is represented in jpvt as follows: If */ +/* > jpvt(j) = i */ +/* > then the jth column of P is the ith canonical unit vector. */ +/* > */ +/* > Partial column norm updating strategy modified by */ +/* > Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* > University of Zagreb, Croatia. */ +/* > -- April 2011 -- */ +/* > For more details see LAPACK Working Note 176. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer * + lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + doublereal temp; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + doublereal temp2; + integer i__, j; + doublereal tol3z; + extern /* Subroutine */ int dlarf_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *); + integer itemp; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *), dgeqr2_(integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *), + dorm2r_(char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer ma; + extern doublereal dlamch_(char *); + integer mn; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *); + doublereal aii; + integer pvt; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --jpvt; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEQPF", &i__1); + return 0; + } + + mn = f2cmin(*m,*n); + tol3z = sqrt(dlamch_("Epsilon")); + +/* Move initial columns up front */ + + itemp = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (jpvt[i__] != 0) { + if (i__ != itemp) { + dswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1], + &c__1); + jpvt[i__] = jpvt[itemp]; + jpvt[itemp] = i__; + } else { + jpvt[i__] = i__; + } + ++itemp; + } else { + jpvt[i__] = i__; + } +/* L10: */ + } + --itemp; + +/* Compute the QR factorization and update remaining columns */ + + if (itemp > 0) { + ma = f2cmin(itemp,*m); + dgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info); + if (ma < *n) { + i__1 = *n - ma; + dorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, & + tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info); + } + } + + if (itemp < mn) { + +/* Initialize partial column norms. The first n elements of */ +/* work store the exact column norms. */ + + i__1 = *n; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + i__2 = *m - itemp; + work[i__] = dnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1); + work[*n + i__] = work[i__]; +/* L20: */ + } + +/* Compute factorization */ + + i__1 = mn; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + +/* Determine ith pivot column and swap if necessary */ + + i__2 = *n - i__ + 1; + pvt = i__ - 1 + idamax_(&i__2, &work[i__], &c__1); + + if (pvt != i__) { + dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[i__]; + jpvt[i__] = itemp; + work[pvt] = work[i__]; + work[*n + pvt] = work[*n + i__]; + } + +/* Generate elementary reflector H(i) */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ * + a_dim1], &c__1, &tau[i__]); + } else { + dlarfg_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], & + c__1, &tau[*m]); + } + + 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[(* + n << 1) + 1]); + a[i__ + i__ * a_dim1] = aii; + } + +/* Update partial column norms */ + + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (work[j] != 0.) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / work[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = f2cmax(d__1,d__2); +/* Computing 2nd power */ + d__1 = work[j] / work[*n + j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + if (*m - i__ > 0) { + i__3 = *m - i__; + work[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], + &c__1); + work[*n + j] = work[j]; + } else { + work[j] = 0.; + work[*n + j] = 0.; + } + } else { + work[j] *= sqrt(temp); + } + } +/* L30: */ + } + +/* L40: */ + } + } + return 0; + +/* End of DGEQPF */ + +} /* dgeqpf_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dggsvd.c b/lapack-netlib/SRC/DEPRECATED/dggsvd.c new file mode 100644 index 000000000..2ed0df56a --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dggsvd.c @@ -0,0 +1,885 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief DGGSVD computes the singular value decomposition (SVD) for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGSVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */ +/* LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), Q( LDQ, * ), U( LDU, * ), */ +/* $ V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DGGSVD3. */ +/* > */ +/* > DGGSVD computes the generalized singular value decomposition (GSVD) */ +/* > of an M-by-N real matrix A and P-by-N real matrix B: */ +/* > */ +/* > U**T*A*Q = D1*( 0 R ), V**T*B*Q = D2*( 0 R ) */ +/* > */ +/* > where U, V and Q are orthogonal matrices. */ +/* > Let K+L = the effective numerical rank of the matrix (A**T,B**T)**T, */ +/* > then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */ +/* > D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */ +/* > following structures, respectively: */ +/* > */ +/* > If M-K-L >= 0, */ +/* > */ +/* > K L */ +/* > D1 = K ( I 0 ) */ +/* > L ( 0 C ) */ +/* > M-K-L ( 0 0 ) */ +/* > */ +/* > K L */ +/* > D2 = L ( 0 S ) */ +/* > P-L ( 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > ( 0 R ) = K ( 0 R11 R12 ) */ +/* > L ( 0 0 R22 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* > S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R is stored in A(1:K+L,N-K-L+1:N) on exit. */ +/* > */ +/* > If M-K-L < 0, */ +/* > */ +/* > K M-K K+L-M */ +/* > D1 = K ( I 0 0 ) */ +/* > M-K ( 0 C 0 ) */ +/* > */ +/* > K M-K K+L-M */ +/* > D2 = M-K ( 0 S 0 ) */ +/* > K+L-M ( 0 0 I ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K M-K K+L-M */ +/* > ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* > M-K ( 0 0 R22 R23 ) */ +/* > K+L-M ( 0 0 0 R33 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* > S = diag( BETA(K+1), ... , BETA(M) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */ +/* > ( 0 R22 R23 ) */ +/* > in B(M-K+1:L,N+M-K-L+1:N) on exit. */ +/* > */ +/* > The routine computes C, S, R, and optionally the orthogonal */ +/* > transformation matrices U, V and Q. */ +/* > */ +/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */ +/* > A and B implicitly gives the SVD of A*inv(B): */ +/* > A*inv(B) = U*(D1*inv(D2))*V**T. */ +/* > If ( A**T,B**T)**T has orthonormal columns, then the GSVD of A and B is */ +/* > also equal to the CS decomposition of A and B. Furthermore, the GSVD */ +/* > can be used to derive the solution of the eigenvalue problem: */ +/* > A**T*A x = lambda* B**T*B x. */ +/* > In some literature, the GSVD of A and B is presented in the form */ +/* > U**T*A*X = ( 0 D1 ), V**T*B*X = ( 0 D2 ) */ +/* > where U and V are orthogonal and X is nonsingular, D1 and D2 are */ +/* > ``diagonal''. The former GSVD form can be converted to the latter */ +/* > form by taking the nonsingular matrix X as */ +/* > */ +/* > X = Q*( I 0 ) */ +/* > ( 0 inv(R) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Orthogonal matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Orthogonal matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Orthogonal matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \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 matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose. */ +/* > K + L = effective numerical rank of (A**T,B**T)**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular matrix R, or part of R. */ +/* > See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains the triangular matrix R if M-K-L < 0. */ +/* > See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > On exit, ALPHA and BETA contain the generalized singular */ +/* > value pairs of A and B; */ +/* > ALPHA(1:K) = 1, */ +/* > BETA(1:K) = 0, */ +/* > and if M-K-L >= 0, */ +/* > ALPHA(K+1:K+L) = C, */ +/* > BETA(K+1:K+L) = S, */ +/* > or if M-K-L < 0, */ +/* > ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */ +/* > BETA(K+1:M) =S, BETA(M+1:K+L) =1 */ +/* > and */ +/* > ALPHA(K+L+1:N) = 0 */ +/* > BETA(K+L+1:N) = 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is DOUBLE PRECISION array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, */ +/* > dimension (f2cmax(3*N,M,P)+N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > On exit, IWORK stores the sorting information. More */ +/* > precisely, the following loop will sort ALPHA */ +/* > for I = K+1, f2cmin(M,K+L) */ +/* > swap ALPHA(I) and ALPHA(IWORK(I)) */ +/* > endfor */ +/* > such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(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, the Jacobi-type procedure failed to */ +/* > converge. For further details, see subroutine DTGSJA. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLA DOUBLE PRECISION */ +/* > TOLB DOUBLE PRECISION */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > rank of (A',B')**T. Generally, they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MAZHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MAZHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERsing */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggsvd_(char *jobu, char *jobv, char *jobq, integer *m, + integer *n, integer *p, integer *k, integer *l, doublereal *a, + integer *lda, doublereal *b, integer *ldb, doublereal *alpha, + doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer + *ldv, doublereal *q, integer *ldq, doublereal *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2; + + /* Local variables */ + integer ibnd; + doublereal tola; + integer isub; + doublereal tolb, unfl, temp, smax; + integer ncallmycycle, i__, j; + extern logical lsame_(char *, char *); + doublereal anorm, bnorm; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical wantq, wantu, wantv; + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dtgsja_(char *, char *, char *, integer *, + integer *, integer *, integer *, integer *, doublereal *, integer + *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *), xerbla_(char *, integer *), dggsvp_(char *, char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *, doublereal *, doublereal *, integer *); + doublereal ulp; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + --iwork; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*p < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -10; + } else if (*ldb < f2cmax(1,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGSVD", &i__1); + return 0; + } + +/* Compute the Frobenius norm of matrices A and B */ + + anorm = dlange_("1", m, n, &a[a_offset], lda, &work[1]); + bnorm = dlange_("1", p, n, &b[b_offset], ldb, &work[1]); + +/* Get machine precision and set up threshold for determining */ +/* the effective numerical rank of the matrices A and B. */ + + ulp = dlamch_("Precision"); + unfl = dlamch_("Safe Minimum"); + tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp; + tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp; + +/* Preprocessing */ + + dggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, & + tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[ + q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], info); + +/* Compute the GSVD of two upper "triangular" matrices */ + + dtgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], + ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[ + v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info); + +/* Sort the singular values and store the pivot indices in IWORK */ +/* Copy ALPHA to WORK, then sort ALPHA in WORK */ + + dcopy_(n, &alpha[1], &c__1, &work[1], &c__1); +/* Computing MIN */ + i__1 = *l, i__2 = *m - *k; + ibnd = f2cmin(i__1,i__2); + i__1 = ibnd; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for largest ALPHA(K+I) */ + + isub = i__; + smax = work[*k + i__]; + i__2 = ibnd; + for (j = i__ + 1; j <= i__2; ++j) { + temp = work[*k + j]; + if (temp > smax) { + isub = j; + smax = temp; + } +/* L10: */ + } + if (isub != i__) { + work[*k + isub] = work[*k + i__]; + work[*k + i__] = smax; + iwork[*k + i__] = *k + isub; + } else { + iwork[*k + i__] = *k + i__; + } +/* L20: */ + } + + return 0; + +/* End of DGGSVD */ + +} /* dggsvd_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dggsvp.c b/lapack-netlib/SRC/DEPRECATED/dggsvp.c new file mode 100644 index 000000000..cda78ae1d --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dggsvp.c @@ -0,0 +1,993 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DGGSVP */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGGSVP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, */ +/* TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, */ +/* IWORK, TAU, WORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */ +/* DOUBLE PRECISION TOLA, TOLB */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DGGSVP3. */ +/* > */ +/* > DGGSVP computes orthogonal matrices U, V and Q such that */ +/* > */ +/* > N-K-L K L */ +/* > U**T*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* > L ( 0 0 A23 ) */ +/* > M-K-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* > M-K ( 0 0 A23 ) */ +/* > */ +/* > N-K-L K L */ +/* > V**T*B*Q = L ( 0 0 B13 ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* > otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */ +/* > numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. */ +/* > */ +/* > This decomposition is the preprocessing step for computing the */ +/* > Generalized Singular Value Decomposition (GSVD), see subroutine */ +/* > DGGSVD. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Orthogonal matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Orthogonal matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Orthogonal matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. 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, A contains the triangular (or trapezoidal) matrix */ +/* > described in the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains the triangular matrix described in */ +/* > the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLA */ +/* > \verbatim */ +/* > TOLA is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLB */ +/* > \verbatim */ +/* > TOLB is DOUBLE PRECISION */ +/* > */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > numerical rank of matrix B and a subblock of A. Generally, */ +/* > they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MACHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose section. */ +/* > K + L = effective numerical rank of (A**T,B**T)**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is DOUBLE PRECISION array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the orthogonal matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the orthogonal matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the orthogonal matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (f2cmax(3*N,M,P)) */ +/* > \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 */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > The subroutine uses LAPACK subroutine DGEQPF for the QR factorization */ +/* > with column pivoting to detect the effective numerical rank of the */ +/* > a matrix. It may be replaced by a better rank determination strategy. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dggsvp_(char *jobu, char *jobv, char *jobq, integer *m, + integer *p, integer *n, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer + *l, doublereal *u, integer *ldu, doublereal *v, integer *ldv, + doublereal *q, integer *ldq, integer *iwork, doublereal *tau, + doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + logical wantq, wantu, wantv; + extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), dgerq2_( + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), dorg2r_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *), + dorm2r_(char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dormr2_(char *, char *, + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *), dgeqpf_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, doublereal *, integer *), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *), dlaset_(char *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *), dlapmt_(logical *, + integer *, integer *, doublereal *, integer *, integer *); + logical forwrd; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --iwork; + --tau; + --work; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + forwrd = TRUE_; + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -8; + } else if (*ldb < f2cmax(1,*p)) { + *info = -10; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGSVP", &i__1); + return 0; + } + +/* QR with column pivoting of B: B*P = V*( S11 S12 ) */ +/* ( 0 0 ) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + dgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info); + +/* Update A := A*P */ + + dlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); + +/* Determine the effective rank of matrix B. */ + + *l = 0; + i__1 = f2cmin(*p,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) > *tolb) { + ++(*l); + } +/* L20: */ + } + + if (wantv) { + +/* Copy the details of V, and form V. */ + + dlaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv); + if (*p > 1) { + i__1 = *p - 1; + dlacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], + ldv); + } + i__1 = f2cmin(*p,*n); + dorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); + } + +/* Clean up B */ + + i__1 = *l - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + if (*p > *l) { + i__1 = *p - *l; + dlaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb); + } + + if (wantq) { + +/* Set Q = I and Update Q := Q*P */ + + dlaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq); + dlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); + } + + if (*p >= *l && *n != *l) { + +/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */ + + dgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); + +/* Update A := A*Z**T */ + + dormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[ + a_offset], lda, &work[1], info); + + if (wantq) { + +/* Update Q := Q*Z**T */ + + dormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1], + &q[q_offset], ldq, &work[1], info); + } + +/* Clean up B */ + + i__1 = *n - *l; + dlaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb); + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + + } + +/* Let N-L L */ +/* A = ( A11 A12 ) M, */ + +/* then the following does the complete QR decomposition of A11: */ + +/* A11 = U*( 0 T12 )*P1**T */ +/* ( 0 0 ) */ + + i__1 = *n - *l; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L70: */ + } + i__1 = *n - *l; + dgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info); + +/* Determine the effective rank of A11 */ + + *k = 0; +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) > *tola) { + ++(*k); + } +/* L80: */ + } + +/* Update A12 := U**T*A12, where A12 = A( 1:M, N-L+1:N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + dorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[( + *n - *l + 1) * a_dim1 + 1], lda, &work[1], info); + + if (wantu) { + +/* Copy the details of U, and form U */ + + dlaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu); + if (*m > 1) { + i__1 = *m - 1; + i__2 = *n - *l; + dlacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] + , ldu); + } +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + dorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); + } + + if (wantq) { + +/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ + + i__1 = *n - *l; + dlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); + } + +/* Clean up A: set the strictly lower triangular part of */ +/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L90: */ + } +/* L100: */ + } + if (*m > *k) { + i__1 = *m - *k; + i__2 = *n - *l; + dlaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1], + lda); + } + + if (*n - *l > *k) { + +/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ + + i__1 = *n - *l; + dgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); + + if (wantq) { + +/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**T */ + + i__1 = *n - *l; + dormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, & + tau[1], &q[q_offset], ldq, &work[1], info); + } + +/* Clean up A */ + + i__1 = *n - *l - *k; + dlaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda); + i__1 = *n - *l; + for (j = *n - *l - *k + 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L110: */ + } +/* L120: */ + } + + } + + if (*m > *k) { + +/* QR factorization of A( K+1:M,N-L+1:N ) */ + + i__1 = *m - *k; + dgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & + work[1], info); + + if (wantu) { + +/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ + + i__1 = *m - *k; +/* Computing MIN */ + i__3 = *m - *k; + i__2 = f2cmin(i__3,*l); + dorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n + - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + + 1], ldu, &work[1], info); + } + +/* Clean up */ + + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L130: */ + } +/* L140: */ + } + + } + + return 0; + +/* End of DGGSVP */ + +} /* dggsvp_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dlahrd.c b/lapack-netlib/SRC/DEPRECATED/dlahrd.c new file mode 100644 index 000000000..d38179143 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dlahrd.c @@ -0,0 +1,721 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below th +e k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformati +on to the unreduced part of A. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLAHRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */ + +/* INTEGER K, LDA, LDT, LDY, N, NB */ +/* DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), */ +/* $ Y( LDY, NB ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DLAHR2. */ +/* > */ +/* > DLAHRD 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. */ +/* > \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. */ +/* > \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 >= f2cmax(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 h a a a ) */ +/* > ( a h a a a ) */ +/* > ( a h 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). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, doublereal * + a, integer *lda, doublereal *tau, doublereal *t, integer *ldt, + doublereal *y, integer *ldy) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + doublereal d__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemv_(char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), dcopy_(integer *, doublereal *, + integer *, doublereal *, integer *), daxpy_(integer *, doublereal + *, doublereal *, integer *, doublereal *, integer *), dtrmv_(char + *, char *, char *, integer *, doublereal *, integer *, doublereal + *, integer *); + doublereal ei; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + 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(1:n,i) */ + +/* Compute i-th column of A - Y * V**T */ + + i__2 = i__ - 1; + dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k + + i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], & + 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[f2cmin(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(1:n,i) */ + + i__2 = *n - *k - i__ + 1; + dgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ * + y_dim1 + 1], &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 = i__ - 1; + dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ * + t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1); + dscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &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; + + return 0; + +/* End of DLAHRD */ + +} /* dlahrd_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dlatzm.c b/lapack-netlib/SRC/DEPRECATED/dlatzm.c new file mode 100644 index 000000000..c204175c9 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dlatzm.c @@ -0,0 +1,626 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATZM */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLATZM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER INCV, LDC, M, N */ +/* DOUBLE PRECISION TAU */ +/* DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DORMRZ. */ +/* > */ +/* > DLATZM applies a Householder matrix generated by DTZRQF to a matrix. */ +/* > */ +/* > Let P = I - tau*u*u**T, u = ( 1 ), */ +/* > ( v ) */ +/* > where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */ +/* > SIDE = 'R'. */ +/* > */ +/* > If SIDE equals 'L', let */ +/* > C = [ C1 ] 1 */ +/* > [ C2 ] m-1 */ +/* > n */ +/* > Then C is overwritten by P*C. */ +/* > */ +/* > If SIDE equals 'R', let */ +/* > C = [ C1, C2 ] m */ +/* > 1 n-1 */ +/* > Then C is overwritten by C*P. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form P * C */ +/* > = 'R': form C * P */ +/* > \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' */ +/* > (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ +/* > The vector v in the representation of P. 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 P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C1 */ +/* > \verbatim */ +/* > C1 is DOUBLE PRECISION array, dimension */ +/* > (LDC,N) if SIDE = 'L' */ +/* > (M,1) if SIDE = 'R' */ +/* > On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */ +/* > if SIDE = 'R'. */ +/* > */ +/* > On exit, the first row of P*C if SIDE = 'L', or the first */ +/* > column of C*P if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C2 */ +/* > \verbatim */ +/* > C2 is DOUBLE PRECISION array, dimension */ +/* > (LDC, N) if SIDE = 'L' */ +/* > (LDC, N-1) if SIDE = 'R' */ +/* > On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */ +/* > m x (n - 1) matrix C2 if SIDE = 'R'. */ +/* > */ +/* > On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the arrays C1 and C2. LDC >= (1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > (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 doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dlatzm_(char *side, integer *m, integer *n, doublereal * + v, integer *incv, doublereal *tau, doublereal *c1, doublereal *c2, + integer *ldc, doublereal *work) +{ + /* System generated locals */ + integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *), daxpy_(integer + *, doublereal *, doublereal *, integer *, doublereal *, integer *) + ; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c2_dim1 = *ldc; + c2_offset = 1 + c2_dim1 * 1; + c2 -= c2_offset; + c1_dim1 = *ldc; + c1_offset = 1 + c1_dim1 * 1; + c1 -= c1_offset; + --work; + + /* Function Body */ + if (f2cmin(*m,*n) == 0 || *tau == 0.) { + return 0; + } + + if (lsame_(side, "L")) { + +/* w := (C1 + v**T * C2)**T */ + + dcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1); + i__1 = *m - 1; + dgemv_("Transpose", &i__1, n, &c_b5, &c2[c2_offset], ldc, &v[1], incv, + &c_b5, &work[1], &c__1); + +/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w**T */ +/* [ C2 ] [ C2 ] [ v ] */ + + d__1 = -(*tau); + daxpy_(n, &d__1, &work[1], &c__1, &c1[c1_offset], ldc); + i__1 = *m - 1; + d__1 = -(*tau); + dger_(&i__1, n, &d__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], + ldc); + + } else if (lsame_(side, "R")) { + +/* w := C1 + C2 * v */ + + dcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1); + i__1 = *n - 1; + dgemv_("No transpose", m, &i__1, &c_b5, &c2[c2_offset], ldc, &v[1], + incv, &c_b5, &work[1], &c__1); + +/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**T] */ + + d__1 = -(*tau); + daxpy_(m, &d__1, &work[1], &c__1, &c1[c1_offset], &c__1); + i__1 = *n - 1; + d__1 = -(*tau); + dger_(m, &i__1, &d__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], + ldc); + } + + return 0; + +/* End of DLATZM */ + +} /* dlatzm_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/dtzrqf.c b/lapack-netlib/SRC/DEPRECATED/dtzrqf.c new file mode 100644 index 000000000..5feea9604 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/dtzrqf.c @@ -0,0 +1,646 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTZRQF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTZRQF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* DOUBLE PRECISION A( LDA, * ), TAU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine DTZRZF. */ +/* > */ +/* > DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */ +/* > to upper triangular form by means of orthogonal transformations. */ +/* > */ +/* > The upper trapezoidal matrix A is factored as */ +/* > */ +/* > A = ( R 0 ) * Z, */ +/* > */ +/* > where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ +/* > triangular matrix. */ +/* > \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 >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the leading M-by-N upper trapezoidal part of the */ +/* > array A must contain the matrix to be factorized. */ +/* > On exit, the leading M-by-M upper triangular part of A */ +/* > contains the upper triangular matrix R, and elements M+1 to */ +/* > N of the first M rows of A, with the array TAU, represent the */ +/* > orthogonal matrix Z as a product of M elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is DOUBLE PRECISION array, dimension (M) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \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 */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The factorization is obtained by Householder's method. The kth */ +/* > transformation matrix, Z( k ), which is used to introduce zeros into */ +/* > the ( m - k + 1 )th row of A, is given in the form */ +/* > */ +/* > Z( k ) = ( I 0 ), */ +/* > ( 0 T( k ) ) */ +/* > */ +/* > where */ +/* > */ +/* > T( k ) = I - tau*u( k )*u( k )**T, u( k ) = ( 1 ), */ +/* > ( 0 ) */ +/* > ( z( k ) ) */ +/* > */ +/* > tau is a scalar and z( k ) is an ( n - m ) element vector. */ +/* > tau and z( k ) are chosen to annihilate the elements of the kth row */ +/* > of X. */ +/* > */ +/* > The scalar tau is returned in the kth element of TAU and the vector */ +/* > u( k ) in the kth row of A, such that the elements of z( k ) are */ +/* > in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* > the upper triangular part of A. */ +/* > */ +/* > Z is given by */ +/* > */ +/* > Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer * + lda, doublereal *tau, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer i__, k; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *), daxpy_(integer + *, doublereal *, doublereal *, integer *, doublereal *, integer *) + ; + integer m1; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *), xerbla_(char *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTZRQF", &i__1); + return 0; + } + +/* Perform the factorization. */ + + if (*m == 0) { + return 0; + } + if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.; +/* L10: */ + } + } else { +/* Computing MIN */ + i__1 = *m + 1; + m1 = f2cmin(i__1,*n); + for (k = *m; k >= 1; --k) { + +/* Use a Householder reflection to zero the kth row of A. */ +/* First set up the reflection. */ + + i__1 = *n - *m + 1; + dlarfg_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[ + k]); + + if (tau[k] != 0. && k > 1) { + +/* We now perform the operation A := A*P( k ). */ + +/* Use the first ( k - 1 ) elements of TAU to store a( k ), */ +/* where a( k ) consists of the first ( k - 1 ) elements of */ +/* the kth column of A. Also let B denote the first */ +/* ( k - 1 ) rows of the last ( n - m ) columns of A. */ + + i__1 = k - 1; + dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1); + +/* Form w = a( k ) + B*z( k ) in TAU. */ + + i__1 = k - 1; + i__2 = *n - *m; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 + + 1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], & + c__1); + +/* Now form a( k ) := a( k ) - tau*w */ +/* and B := B - tau*w*z( k )**T. */ + + i__1 = k - 1; + d__1 = -tau[k]; + daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + i__1 = k - 1; + i__2 = *n - *m; + d__1 = -tau[k]; + dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1] + , lda, &a[m1 * a_dim1 + 1], lda); + } +/* L20: */ + } + } + + return 0; + +/* End of DTZRQF */ + +} /* dtzrqf_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/sgegs.c b/lapack-netlib/SRC/DEPRECATED/sgegs.c new file mode 100644 index 000000000..c8adb9539 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/sgegs.c @@ -0,0 +1,1005 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief SGEGS computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matr +ices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGEGS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, */ +/* ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, */ +/* LWORK, INFO ) */ + +/* CHARACTER JOBVSL, JOBVSR */ +/* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N */ +/* REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), */ +/* $ VSR( LDVSR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine SGGES. */ +/* > */ +/* > SGEGS computes the eigenvalues, real Schur form, and, optionally, */ +/* > left and or/right Schur vectors of a real matrix pair (A,B). */ +/* > Given two square matrices A and B, the generalized real Schur */ +/* > factorization has the form */ +/* > */ +/* > A = Q*S*Z**T, B = Q*T*Z**T */ +/* > */ +/* > where Q and Z are orthogonal matrices, T is upper triangular, and S */ +/* > is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */ +/* > blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */ +/* > of eigenvalues of (A,B). The columns of Q are the left Schur vectors */ +/* > and the columns of Z are the right Schur vectors. */ +/* > */ +/* > If only the eigenvalues of (A,B) are needed, the driver routine */ +/* > SGEGV should be used instead. See SGEGV for a description of the */ +/* > eigenvalues of the generalized nonsymmetric eigenvalue problem */ +/* > (GNEP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVSL */ +/* > \verbatim */ +/* > JOBVSL is CHARACTER*1 */ +/* > = 'N': do not compute the left Schur vectors; */ +/* > = 'V': compute the left Schur vectors (returned in VSL). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVSR */ +/* > \verbatim */ +/* > JOBVSR is CHARACTER*1 */ +/* > = 'N': do not compute the right Schur vectors; */ +/* > = 'V': compute the right Schur vectors (returned in VSR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VSL, and VSR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, N) */ +/* > On entry, the matrix A. */ +/* > On exit, the upper quasi-triangular matrix S from the */ +/* > generalized real Schur factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, N) */ +/* > On entry, the matrix B. */ +/* > On exit, the upper triangular matrix T from the generalized */ +/* > real Schur factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is REAL array, dimension (N) */ +/* > The real parts of each scalar alpha defining an eigenvalue */ +/* > of GNEP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is REAL array, dimension (N) */ +/* > The imaginary parts of each scalar alpha defining an */ +/* > eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */ +/* > eigenvalue is real; if positive, then the j-th and (j+1)-st */ +/* > eigenvalues are a complex conjugate pair, with */ +/* > ALPHAI(j+1) = -ALPHAI(j). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is REAL array, dimension (N) */ +/* > The scalars beta that define the eigenvalues of GNEP. */ +/* > Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ +/* > beta = BETA(j) represent the j-th eigenvalue of the matrix */ +/* > pair (A,B), in one of the forms lambda = alpha/beta or */ +/* > mu = beta/alpha. Since either lambda or mu may overflow, */ +/* > they should not, in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSL */ +/* > \verbatim */ +/* > VSL is REAL array, dimension (LDVSL,N) */ +/* > If JOBVSL = 'V', the matrix of left Schur vectors Q. */ +/* > Not referenced if JOBVSL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSL */ +/* > \verbatim */ +/* > LDVSL is INTEGER */ +/* > The leading dimension of the matrix VSL. LDVSL >=1, and */ +/* > if JOBVSL = 'V', LDVSL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSR */ +/* > \verbatim */ +/* > VSR is REAL array, dimension (LDVSR,N) */ +/* > If JOBVSR = 'V', the matrix of right Schur vectors Z. */ +/* > Not referenced if JOBVSR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSR */ +/* > \verbatim */ +/* > LDVSR is INTEGER */ +/* > The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* > if JOBVSR = 'V', LDVSR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL 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 >= f2cmax(1,4*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > To compute the optimal value of LWORK, call ILAENV to get */ +/* > blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: */ +/* > NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR */ +/* > The optimal LWORK is 2*N + N*(NB+1). */ +/* > */ +/* > 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. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. (A,B) are not in Schur */ +/* > form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ +/* > be correct for j=INFO+1,...,N. */ +/* > > N: errors that usually indicate LAPACK problems: */ +/* > =N+1: error return from SGGBAL */ +/* > =N+2: error return from SGEQRF */ +/* > =N+3: error return from SORMQR */ +/* > =N+4: error return from SORGQR */ +/* > =N+5: error return from SGGHRD */ +/* > =N+6: error return from SHGEQZ (other than failed */ +/* > iteration) */ +/* > =N+7: error return from SGGBAK (computing VSL) */ +/* > =N+8: error return from SGGBAK (computing VSR) */ +/* > =N+9: error return from SLASCL (various places) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int sgegs_(char *jobvsl, char *jobvsr, integer *n, real *a, + integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real + *beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real * + work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2; + + /* Local variables */ + real anrm, bnrm; + integer itau, lopt; + extern logical lsame_(char *, char *); + integer ileft, iinfo, icols; + logical ilvsl; + integer iwork; + logical ilvsr; + integer irows, nb; + extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, integer * + ), sggbal_(char *, integer *, real *, integer *, + real *, integer *, integer *, integer *, real *, real *, real *, + integer *); + logical ilascl, ilbscl; + extern real slamch_(char *), slange_(char *, integer *, integer *, + real *, integer *, real *); + real safmin; + extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *, integer *), xerbla_(char *, + integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + real bignum; + extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *); + integer ijobvl, iright; + extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer + *, real *, real *, integer *, integer *); + integer ijobvr; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *), slaset_(char *, integer *, + integer *, real *, real *, real *, integer *); + real anrmto; + integer lwkmin, nb1, nb2, nb3; + real bnrmto; + extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *, + integer *, integer *, real *, integer *, real *, integer *, real * + , real *, real *, real *, integer *, real *, integer *, real *, + integer *, integer *); + real smlnum; + extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real + *, integer *, real *, real *, integer *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *, + integer *, real *, integer *, real *, real *, integer *, real *, + integer *, integer *); + integer ihi, ilo; + real eps; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1 * 1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1 * 1; + vsr -= vsr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = FALSE_; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = TRUE_; + } else { + ijobvl = -1; + ilvsl = FALSE_; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = FALSE_; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = TRUE_; + } else { + ijobvr = -1; + ilvsr = FALSE_; + } + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 2; + lwkmin = f2cmax(i__1,1); + lwkopt = lwkmin; + work[1] = (real) lwkopt; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -12; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -14; + } else if (*lwork < lwkmin && ! lquery) { + *info = -16; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "SORMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "SORGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); + lopt = (*n << 1) + *n * (nb + 1); + work[1] = (real) lopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGEGS ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = slamch_("E") * slamch_("B"); + safmin = slamch_("S"); + smlnum = *n * safmin / eps; + bignum = 1.f / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = FALSE_; + if (anrm > 0.f && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + + if (ilascl) { + slascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = FALSE_; + if (bnrm > 0.f && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + + if (ilbscl) { + slascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ +/* Workspace layout: (2*N words -- "work..." not actually used) */ +/* left_permutation, right_permutation, work... */ + + ileft = 1; + iright = *n + 1; + iwork = iright + *n; + sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L10; + } + +/* Reduce B to triangular form, and initialize VSL and/or VSR */ +/* Workspace layout: ("work..." must have at least N words) */ +/* left_permutation, right_permutation, tau, work... */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwork; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L10; + } + + i__1 = *lwork + 1 - iwork; + sormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L10; + } + + if (ilvsl) { + slaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl); + i__1 = irows - 1; + i__2 = irows - 1; + slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo + + 1 + ilo * vsl_dim1], ldvsl); + i__1 = *lwork + 1 - iwork; + sorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L10; + } + } + + if (ilvsr) { + slaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ + + sgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 5; + goto L10; + } + +/* Perform QZ algorithm, computing Schur vectors if desired */ +/* Workspace layout: ("work..." must have at least 1 word) */ +/* left_permutation, right_permutation, work... */ + + iwork = itau; + i__1 = *lwork + 1 - iwork; + shgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] + , ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L10; + } + +/* Apply permutation to VSL and VSR */ + + if (ilvsl) { + sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ + vsl_offset], ldvsl, &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L10; + } + } + if (ilvsr) { + sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ + vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L10; + } + } + +/* Undo scaling */ + + if (ilascl) { + slascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + slascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + slascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + + if (ilbscl) { + slascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + slascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +L10: + work[1] = (real) lwkopt; + + return 0; + +/* End of SGEGS */ + +} /* sgegs_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/sgegv.c b/lapack-netlib/SRC/DEPRECATED/sgegv.c new file mode 100644 index 000000000..2e0601ec9 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/sgegv.c @@ -0,0 +1,1295 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief SGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGEGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, */ +/* BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) */ + +/* CHARACTER JOBVL, JOBVR */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N */ +/* REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine SGGEV. */ +/* > */ +/* > SGEGV computes the eigenvalues and, optionally, the left and/or right */ +/* > eigenvectors of a real matrix pair (A,B). */ +/* > Given two square matrices A and B, */ +/* > the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */ +/* > eigenvalues lambda and corresponding (non-zero) eigenvectors x such */ +/* > that */ +/* > */ +/* > A*x = lambda*B*x. */ +/* > */ +/* > An alternate form is to find the eigenvalues mu and corresponding */ +/* > eigenvectors y such that */ +/* > */ +/* > mu*A*y = B*y. */ +/* > */ +/* > These two forms are equivalent with mu = 1/lambda and x = y if */ +/* > neither lambda nor mu is zero. In order to deal with the case that */ +/* > lambda or mu is zero or small, two values alpha and beta are returned */ +/* > for each eigenvalue, such that lambda = alpha/beta and */ +/* > mu = beta/alpha. */ +/* > */ +/* > The vectors x and y in the above equations are right eigenvectors of */ +/* > the matrix pair (A,B). Vectors u and v satisfying */ +/* > */ +/* > u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */ +/* > */ +/* > are left eigenvectors of (A,B). */ +/* > */ +/* > Note: this routine performs "full balancing" on A and B */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': do not compute the left generalized eigenvectors; */ +/* > = 'V': compute the left generalized eigenvectors (returned */ +/* > in VL). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': do not compute the right generalized eigenvectors; */ +/* > = 'V': compute the right generalized eigenvectors (returned */ +/* > in VR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VL, and VR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, N) */ +/* > On entry, the matrix A. */ +/* > If JOBVL = 'V' or JOBVR = 'V', then on exit A */ +/* > contains the real Schur form of A from the generalized Schur */ +/* > factorization of the pair (A,B) after balancing. */ +/* > If no eigenvectors were computed, then only the diagonal */ +/* > blocks from the Schur form will be correct. See SGGHRD and */ +/* > SHGEQZ for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, N) */ +/* > On entry, the matrix B. */ +/* > If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */ +/* > upper triangular matrix obtained from B in the generalized */ +/* > Schur factorization of the pair (A,B) after balancing. */ +/* > If no eigenvectors were computed, then only those elements of */ +/* > B corresponding to the diagonal blocks from the Schur form of */ +/* > A will be correct. See SGGHRD and SHGEQZ for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is REAL array, dimension (N) */ +/* > The real parts of each scalar alpha defining an eigenvalue of */ +/* > GNEP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is REAL array, dimension (N) */ +/* > The imaginary parts of each scalar alpha defining an */ +/* > eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */ +/* > eigenvalue is real; if positive, then the j-th and */ +/* > (j+1)-st eigenvalues are a complex conjugate pair, with */ +/* > ALPHAI(j+1) = -ALPHAI(j). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is REAL array, dimension (N) */ +/* > The scalars beta that define the eigenvalues of GNEP. */ +/* > */ +/* > Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ +/* > beta = BETA(j) represent the j-th eigenvalue of the matrix */ +/* > pair (A,B), in one of the forms lambda = alpha/beta or */ +/* > mu = beta/alpha. Since either lambda or mu may overflow, */ +/* > they should not, in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored */ +/* > in the columns of VL, in the same order as their eigenvalues. */ +/* > If the j-th eigenvalue is real, then u(j) = VL(:,j). */ +/* > 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). */ +/* > */ +/* > Each eigenvector is scaled so that its largest component has */ +/* > abs(real part) + abs(imag. part) = 1, except for eigenvectors */ +/* > corresponding to an eigenvalue with alpha = beta = 0, which */ +/* > are set to zero. */ +/* > Not referenced if JOBVL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the matrix VL. LDVL >= 1, and */ +/* > if JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is REAL array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors x(j) are stored */ +/* > in the columns of VR, in the same order as their eigenvalues. */ +/* > If the j-th eigenvalue is real, then x(j) = VR(:,j). */ +/* > If the j-th and (j+1)-st eigenvalues form a complex conjugate */ +/* > pair, then */ +/* > x(j) = VR(:,j) + i*VR(:,j+1) */ +/* > and */ +/* > x(j+1) = VR(:,j) - i*VR(:,j+1). */ +/* > */ +/* > Each eigenvector is scaled so that its largest component has */ +/* > abs(real part) + abs(imag. part) = 1, except for eigenvalues */ +/* > corresponding to an eigenvalue with alpha = beta = 0, which */ +/* > are set to zero. */ +/* > Not referenced if JOBVR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the matrix VR. LDVR >= 1, and */ +/* > if JOBVR = 'V', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL 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 >= f2cmax(1,8*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > To compute the optimal value of LWORK, call ILAENV to get */ +/* > blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: */ +/* > NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR; */ +/* > The optimal LWORK is: */ +/* > 2*N + MAX( 6*N, N*(NB+1) ). */ +/* > */ +/* > 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. */ +/* > = 1,...,N: */ +/* > The QZ iteration failed. No eigenvectors have been */ +/* > calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ +/* > should be correct for j=INFO+1,...,N. */ +/* > > N: errors that usually indicate LAPACK problems: */ +/* > =N+1: error return from SGGBAL */ +/* > =N+2: error return from SGEQRF */ +/* > =N+3: error return from SORMQR */ +/* > =N+4: error return from SORGQR */ +/* > =N+5: error return from SGGHRD */ +/* > =N+6: error return from SHGEQZ (other than failed */ +/* > iteration) */ +/* > =N+7: error return from STGEVC */ +/* > =N+8: error return from SGGBAK (computing VL) */ +/* > =N+9: error return from SGGBAK (computing VR) */ +/* > =N+10: error return from SLASCL (various calls) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGEeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Balancing */ +/* > --------- */ +/* > */ +/* > This driver calls SGGBAL to both permute and scale rows and columns */ +/* > of A and B. The permutations PL and PR are chosen so that PL*A*PR */ +/* > and PL*B*R will be upper triangular except for the diagonal blocks */ +/* > A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */ +/* > possible. The diagonal scaling matrices DL and DR are chosen so */ +/* > that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */ +/* > one (except for the elements that start out zero.) */ +/* > */ +/* > After the eigenvalues and eigenvectors of the balanced matrices */ +/* > have been computed, SGGBAK transforms the eigenvectors back to what */ +/* > they would have been (in perfect arithmetic) if they had not been */ +/* > balanced. */ +/* > */ +/* > Contents of A and B on Exit */ +/* > -------- -- - --- - -- ---- */ +/* > */ +/* > If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */ +/* > both), then on exit the arrays A and B will contain the real Schur */ +/* > form[*] of the "balanced" versions of A and B. If no eigenvectors */ +/* > are computed, then only the diagonal blocks will be correct. */ +/* > */ +/* > [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations", */ +/* > by Golub & van Loan, pub. by Johns Hopkins U. Press. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sgegv_(char *jobvl, char *jobvr, integer *n, real *a, + integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real + *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + real absb, anrm, bnrm; + integer itau; + real temp; + logical ilvl, ilvr; + integer lopt; + real anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta; + extern logical lsame_(char *, char *); + integer ileft, iinfo, icols, iwork, irows, jc, nb, in, jr; + real salfai; + extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, integer * + ), sggbal_(char *, integer *, real *, integer *, + real *, integer *, integer *, integer *, real *, real *, real *, + integer *); + real salfar; + extern real slamch_(char *), slange_(char *, integer *, integer *, + real *, integer *, real *); + real safmin; + extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *, integer *); + real safmax; + char chtemp[1]; + logical ldumma[1]; + extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *), xerbla_(char *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ijobvl, iright; + logical ilimit; + extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer + *, real *, real *, integer *, integer *); + integer ijobvr; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *), slaset_(char *, integer *, + integer *, real *, real *, real *, integer *), stgevc_( + char *, char *, logical *, integer *, real *, integer *, real *, + integer *, real *, integer *, real *, integer *, integer *, + integer *, real *, integer *); + real onepls; + integer lwkmin, nb1, nb2, nb3; + extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *, + integer *, integer *, real *, integer *, real *, integer *, real * + , real *, real *, real *, integer *, real *, integer *, real *, + integer *, integer *), sorgqr_(integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + , integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *, + integer *, real *, integer *, real *, real *, integer *, real *, + integer *, integer *); + integer ihi, ilo; + real eps; + logical ilv; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = FALSE_; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = TRUE_; + } else { + ijobvl = -1; + ilvl = FALSE_; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = FALSE_; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = TRUE_; + } else { + ijobvr = -1; + ilvr = FALSE_; + } + ilv = ilvl || ilvr; + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 3; + lwkmin = f2cmax(i__1,1); + lwkopt = lwkmin; + work[1] = (real) lwkopt; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -12; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -14; + } else if (*lwork < lwkmin && ! lquery) { + *info = -16; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "SORMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "SORGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); +/* Computing MAX */ + i__1 = *n * 6, i__2 = *n * (nb + 1); + lopt = (*n << 1) + f2cmax(i__1,i__2); + work[1] = (real) lopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGEGV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = slamch_("E") * slamch_("B"); + safmin = slamch_("S"); + safmin += safmin; + safmax = 1.f / safmin; + onepls = eps * 4 + 1.f; + +/* Scale A */ + + anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]); + anrm1 = anrm; + anrm2 = 1.f; + if (anrm < 1.f) { + if (safmax * anrm < 1.f) { + anrm1 = safmin; + anrm2 = safmax * anrm; + } + } + + if (anrm > 0.f) { + slascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Scale B */ + + bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]); + bnrm1 = bnrm; + bnrm2 = 1.f; + if (bnrm < 1.f) { + if (safmax * bnrm < 1.f) { + bnrm1 = safmin; + bnrm2 = safmax * bnrm; + } + } + + if (bnrm > 0.f) { + slascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ +/* Workspace layout: (8*N words -- "work" requires 6*N words) */ +/* left_permutation, right_permutation, work... */ + + ileft = 1; + iright = *n + 1; + iwork = iright + *n; + sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L120; + } + +/* Reduce B to triangular form, and initialize VL and/or VR */ +/* Workspace layout: ("work..." must have at least N words) */ +/* left_permutation, right_permutation, tau, work... */ + + irows = ihi + 1 - ilo; + if (ilv) { + icols = *n + 1 - ilo; + } else { + icols = irows; + } + itau = iwork; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L120; + } + + i__1 = *lwork + 1 - iwork; + sormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L120; + } + + if (ilvl) { + slaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl) + ; + i__1 = irows - 1; + i__2 = irows - 1; + slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo + + 1 + ilo * vl_dim1], ldvl); + i__1 = *lwork + 1 - iwork; + sorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ + itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L120; + } + } + + if (ilvr) { + slaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr) + ; + } + +/* Reduce to generalized Hessenberg form */ + + if (ilv) { + +/* Eigenvectors requested -- work on whole matrix. */ + + sgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo); + } else { + sgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, + &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &iinfo); + } + if (iinfo != 0) { + *info = *n + 5; + goto L120; + } + +/* Perform QZ algorithm */ +/* Workspace layout: ("work..." must have at least 1 word) */ +/* left_permutation, right_permutation, work... */ + + iwork = itau; + if (ilv) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + i__1 = *lwork + 1 - iwork; + shgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L120; + } + + if (ilv) { + +/* Compute Eigenvectors (STGEVC requires 6*N words of workspace) */ + + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + + stgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, + &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ + iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L120; + } + +/* Undo balancing on VL and VR, rescale */ + + if (ilvl) { + sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vl[vl_offset], ldvl, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L120; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.f) { + goto L50; + } + temp = 0.f; + if (alphai[jc] == 0.f) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + r__2 = temp, r__3 = (r__1 = vl[jr + jc * vl_dim1], + abs(r__1)); + temp = f2cmax(r__2,r__3); +/* L10: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + r__3 = temp, r__4 = (r__1 = vl[jr + jc * vl_dim1], + abs(r__1)) + (r__2 = vl[jr + (jc + 1) * + vl_dim1], abs(r__2)); + temp = f2cmax(r__3,r__4); +/* L20: */ + } + } + if (temp < safmin) { + goto L50; + } + temp = 1.f / temp; + if (alphai[jc] == 0.f) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; +/* L30: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; + vl[jr + (jc + 1) * vl_dim1] *= temp; +/* L40: */ + } + } +L50: + ; + } + } + if (ilvr) { + sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vr[vr_offset], ldvr, &iinfo); + if (iinfo != 0) { + *info = *n + 9; + goto L120; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.f) { + goto L100; + } + temp = 0.f; + if (alphai[jc] == 0.f) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + r__2 = temp, r__3 = (r__1 = vr[jr + jc * vr_dim1], + abs(r__1)); + temp = f2cmax(r__2,r__3); +/* L60: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + r__3 = temp, r__4 = (r__1 = vr[jr + jc * vr_dim1], + abs(r__1)) + (r__2 = vr[jr + (jc + 1) * + vr_dim1], abs(r__2)); + temp = f2cmax(r__3,r__4); +/* L70: */ + } + } + if (temp < safmin) { + goto L100; + } + temp = 1.f / temp; + if (alphai[jc] == 0.f) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; +/* L80: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; + vr[jr + (jc + 1) * vr_dim1] *= temp; +/* L90: */ + } + } +L100: + ; + } + } + +/* End of eigenvector calculation */ + + } + +/* Undo scaling in alpha, beta */ + +/* Note: this does not give the alpha and beta for the unscaled */ +/* problem. */ + +/* Un-scaling is limited to avoid underflow in alpha and beta */ +/* if they are significant. */ + + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + absar = (r__1 = alphar[jc], abs(r__1)); + absai = (r__1 = alphai[jc], abs(r__1)); + absb = (r__1 = beta[jc], abs(r__1)); + salfar = anrm * alphar[jc]; + salfai = anrm * alphai[jc]; + sbeta = bnrm * beta[jc]; + ilimit = FALSE_; + scale = 1.f; + +/* Check for significant underflow in ALPHAI */ + +/* Computing MAX */ + r__1 = safmin, r__2 = eps * absar, r__1 = f2cmax(r__1,r__2), r__2 = eps * + absb; + if (abs(salfai) < safmin && absai >= f2cmax(r__1,r__2)) { + ilimit = TRUE_; +/* Computing MAX */ + r__1 = onepls * safmin, r__2 = anrm2 * absai; + scale = onepls * safmin / anrm1 / f2cmax(r__1,r__2); + + } else if (salfai == 0.f) { + +/* If insignificant underflow in ALPHAI, then make the */ +/* conjugate eigenvalue real. */ + + if (alphai[jc] < 0.f && jc > 1) { + alphai[jc - 1] = 0.f; + } else if (alphai[jc] > 0.f && jc < *n) { + alphai[jc + 1] = 0.f; + } + } + +/* Check for significant underflow in ALPHAR */ + +/* Computing MAX */ + r__1 = safmin, r__2 = eps * absai, r__1 = f2cmax(r__1,r__2), r__2 = eps * + absb; + if (abs(salfar) < safmin && absar >= f2cmax(r__1,r__2)) { + ilimit = TRUE_; +/* Computing MAX */ +/* Computing MAX */ + r__3 = onepls * safmin, r__4 = anrm2 * absar; + r__1 = scale, r__2 = onepls * safmin / anrm1 / f2cmax(r__3,r__4); + scale = f2cmax(r__1,r__2); + } + +/* Check for significant underflow in BETA */ + +/* Computing MAX */ + r__1 = safmin, r__2 = eps * absar, r__1 = f2cmax(r__1,r__2), r__2 = eps * + absai; + if (abs(sbeta) < safmin && absb >= f2cmax(r__1,r__2)) { + ilimit = TRUE_; +/* Computing MAX */ +/* Computing MAX */ + r__3 = onepls * safmin, r__4 = bnrm2 * absb; + r__1 = scale, r__2 = onepls * safmin / bnrm1 / f2cmax(r__3,r__4); + scale = f2cmax(r__1,r__2); + } + +/* Check for possible overflow when limiting scaling */ + + if (ilimit) { +/* Computing MAX */ + r__1 = abs(salfar), r__2 = abs(salfai), r__1 = f2cmax(r__1,r__2), + r__2 = abs(sbeta); + temp = scale * safmin * f2cmax(r__1,r__2); + if (temp > 1.f) { + scale /= temp; + } + if (scale < 1.f) { + ilimit = FALSE_; + } + } + +/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */ + + if (ilimit) { + salfar = scale * alphar[jc] * anrm; + salfai = scale * alphai[jc] * anrm; + sbeta = scale * beta[jc] * bnrm; + } + alphar[jc] = salfar; + alphai[jc] = salfai; + beta[jc] = sbeta; +/* L110: */ + } + +L120: + work[1] = (real) lwkopt; + + return 0; + +/* End of SGEGV */ + +} /* sgegv_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/sgelsx.c b/lapack-netlib/SRC/DEPRECATED/sgelsx.c new file mode 100644 index 000000000..22c991e8f --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/sgelsx.c @@ -0,0 +1,870 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief SGELSX solves overdetermined or underdetermined systems for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGELSX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */ +/* WORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, M, N, NRHS, RANK */ +/* REAL RCOND */ +/* INTEGER JPVT( * ) */ +/* REAL A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine SGELSY. */ +/* > */ +/* > SGELSX computes the minimum-norm solution to a real linear least */ +/* > squares problem: */ +/* > minimize || A * X - B || */ +/* > using a complete orthogonal factorization of A. A is an M-by-N */ +/* > matrix which may be rank-deficient. */ +/* > */ +/* > Several right hand side vectors b and solution vectors x can be */ +/* > handled in a single call; they are stored as the columns of the */ +/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* > matrix X. */ +/* > */ +/* > The routine first computes a QR factorization with column pivoting: */ +/* > A * P = Q * [ R11 R12 ] */ +/* > [ 0 R22 ] */ +/* > with R11 defined as the largest leading submatrix whose estimated */ +/* > condition number is less than 1/RCOND. The order of R11, RANK, */ +/* > is the effective rank of A. */ +/* > */ +/* > Then, R22 is considered to be negligible, and R12 is annihilated */ +/* > by orthogonal transformations from the right, arriving at the */ +/* > complete orthogonal factorization: */ +/* > A * P = Q * [ T11 0 ] * Z */ +/* > [ 0 0 ] */ +/* > The minimum-norm solution is then */ +/* > X = P * Z**T [ inv(T11)*Q1**T*B ] */ +/* > [ 0 ] */ +/* > where Q1 consists of the first RANK columns of Q. */ +/* > \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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of */ +/* > columns of matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A has been overwritten by details of its */ +/* > complete orthogonal factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On entry, the M-by-NRHS right hand side matrix B. */ +/* > On exit, the N-by-NRHS solution matrix X. */ +/* > If m >= n and RANK = n, the residual sum-of-squares for */ +/* > the solution in the i-th column is given by the sum of */ +/* > squares of elements N+1:M in that column. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is an */ +/* > initial column, otherwise it is a free column. Before */ +/* > the QR factorization of A, all initial columns are */ +/* > permuted to the leading positions; only the remaining */ +/* > free columns are moved as a result of column pivoting */ +/* > during the factorization. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > RCOND is used to determine the effective rank of A, which */ +/* > is defined as the order of the largest leading triangular */ +/* > submatrix R11 in the QR factorization with pivoting of A, */ +/* > whose estimated condition number < 1/RCOND. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The effective rank of A, i.e., the order of the submatrix */ +/* > R11. This is the same as the order of the submatrix T11 */ +/* > in the complete orthogonal factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension */ +/* > (f2cmax( f2cmin(M,N)+3*N, 2*f2cmin(M,N)+NRHS )), */ +/* > \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 realGEsolve */ + +/* ===================================================================== */ +/* Subroutine */ int sgelsx_(integer *m, integer *n, integer *nrhs, real *a, + integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond, + integer *rank, real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + real r__1; + + /* Local variables */ + real anrm, bnrm, smin, smax; + integer i__, j, k, iascl, ibscl, ismin, ismax; + real c1, c2, s1, s2, t1, t2; + extern /* Subroutine */ int strsm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ), slaic1_(integer *, integer *, + real *, real *, real *, real *, real *, real *, real *), sorm2r_( + char *, char *, integer *, integer *, integer *, real *, integer * + , real *, real *, integer *, real *, integer *), + slabad_(real *, real *); + integer mn; + extern real slamch_(char *), slange_(char *, integer *, integer *, + real *, integer *, real *); + extern /* Subroutine */ int xerbla_(char *, integer *); + real bignum; + extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *), sgeqpf_(integer *, integer *, real *, integer *, integer + *, real *, real *, integer *), slaset_(char *, integer *, integer + *, real *, real *, real *, integer *); + real sminpr, smaxpr, smlnum; + extern /* Subroutine */ int slatzm_(char *, integer *, integer *, real *, + integer *, real *, real *, real *, integer *, real *), + stzrqf_(integer *, integer *, real *, integer *, real *, integer * + ); + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --jpvt; + --work; + + /* Function Body */ + mn = f2cmin(*m,*n); + ismin = mn + 1; + ismax = (mn << 1) + 1; + +/* Test the input arguments. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*m); + if (*ldb < f2cmax(i__1,*n)) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGELSX", &i__1); + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*nrhs) == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + smlnum = slamch_("S") / slamch_("P"); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + +/* Scale A, B if f2cmax elements outside range [SMLNUM,BIGNUM] */ + + anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]); + iascl = 0; + if (anrm > 0.f && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.f) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = f2cmax(*m,*n); + slaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb); + *rank = 0; + goto L100; + } + + bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); + ibscl = 0; + if (bnrm > 0.f && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Compute QR factorization with column pivoting of A: */ +/* A * P = Q * R */ + + sgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info); + +/* workspace 3*N. Details of Householder rotations stored */ +/* in WORK(1:MN). */ + +/* Determine RANK using incremental condition estimation */ + + work[ismin] = 1.f; + work[ismax] = 1.f; + smax = (r__1 = a[a_dim1 + 1], abs(r__1)); + smin = smax; + if ((r__1 = a[a_dim1 + 1], abs(r__1)) == 0.f) { + *rank = 0; + i__1 = f2cmax(*m,*n); + slaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb); + goto L100; + } else { + *rank = 1; + } + +L10: + if (*rank < mn) { + i__ = *rank + 1; + slaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &sminpr, &s1, &c1); + slaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &smaxpr, &s2, &c2); + + if (smaxpr * *rcond <= sminpr) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1]; + work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1]; +/* L20: */ + } + work[ismin + *rank] = c1; + work[ismax + *rank] = c2; + smin = sminpr; + smax = smaxpr; + ++(*rank); + goto L10; + } + } + +/* Logically partition R = [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* where R11 = R(1:RANK,1:RANK) */ + +/* [R11,R12] = [ T11, 0 ] * Y */ + + if (*rank < *n) { + stzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info); + } + +/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ + +/* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) */ + + sorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], & + b[b_offset], ldb, &work[(mn << 1) + 1], info); + +/* workspace NRHS */ + +/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ + + strsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, & + a[a_offset], lda, &b[b_offset], ldb); + + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + b[i__ + j * b_dim1] = 0.f; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Y**T * B(1:N,1:NRHS) */ + + if (*rank < *n) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - *rank + 1; + slatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, + &work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], + ldb, &work[(mn << 1) + 1]); +/* L50: */ + } + } + +/* workspace NRHS */ + +/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[(mn << 1) + i__] = 1.f; +/* L60: */ + } + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[(mn << 1) + i__] == 1.f) { + if (jpvt[i__] != i__) { + k = i__; + t1 = b[k + j * b_dim1]; + t2 = b[jpvt[k] + j * b_dim1]; +L70: + b[jpvt[k] + j * b_dim1] = t1; + work[(mn << 1) + k] = 0.f; + t1 = t2; + k = jpvt[k]; + t2 = b[jpvt[k] + j * b_dim1]; + if (jpvt[k] != i__) { + goto L70; + } + b[i__ + j * b_dim1] = t1; + work[(mn << 1) + k] = 0.f; + } + } +/* L80: */ + } +/* L90: */ + } + +/* Undo scaling */ + + if (iascl == 1) { + slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + slascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], + lda, info); + } else if (iascl == 2) { + slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + slascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], + lda, info); + } + if (ibscl == 1) { + slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L100: + + return 0; + +/* End of SGELSX */ + +} /* sgelsx_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/sgeqpf.c b/lapack-netlib/SRC/DEPRECATED/sgeqpf.c new file mode 100644 index 000000000..4e837a33c --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/sgeqpf.c @@ -0,0 +1,729 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SGEQPF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGEQPF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* INTEGER JPVT( * ) */ +/* REAL A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine SGEQP3. */ +/* > */ +/* > SGEQPF computes a QR factorization with column pivoting of a */ +/* > real M-by-N matrix A: A*P = Q*R. */ +/* > \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 REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the upper triangle of the array contains the */ +/* > f2cmin(M,N)-by-N upper triangular matrix R; the elements */ +/* > below the diagonal, together with the array TAU, */ +/* > represent the orthogonal matrix Q as a product of */ +/* > f2cmin(m,n) elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */ +/* > to the front of A*P (a leading column); if JPVT(i) = 0, */ +/* > the i-th column of A is a free column. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL 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 */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(n) */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H = 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). */ +/* > */ +/* > The matrix P is represented in jpvt as follows: If */ +/* > jpvt(j) = i */ +/* > then the jth column of P is the ith canonical unit vector. */ +/* > */ +/* > Partial column norm updating strategy modified by */ +/* > Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* > University of Zagreb, Croatia. */ +/* > -- April 2011 -- */ +/* > For more details see LAPACK Working Note 176. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sgeqpf_(integer *m, integer *n, real *a, integer *lda, + integer *jpvt, real *tau, real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + real temp, temp2; + extern real snrm2_(integer *, real *, integer *); + integer i__, j; + real tol3z; + extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, + integer *, real *, real *, integer *, real *); + integer itemp; + extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, + integer *), sgeqr2_(integer *, integer *, real *, integer *, real + *, real *, integer *); + integer ma; + extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *, + integer *, real *, integer *, real *, real *, integer *, real *, + integer *); + integer mn; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *), slarfg_( + integer *, real *, real *, integer *, real *); + extern integer isamax_(integer *, real *, integer *); + real aii; + integer pvt; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --jpvt; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGEQPF", &i__1); + return 0; + } + + mn = f2cmin(*m,*n); + tol3z = sqrt(slamch_("Epsilon")); + +/* Move initial columns up front */ + + itemp = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (jpvt[i__] != 0) { + if (i__ != itemp) { + sswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1], + &c__1); + jpvt[i__] = jpvt[itemp]; + jpvt[itemp] = i__; + } else { + jpvt[i__] = i__; + } + ++itemp; + } else { + jpvt[i__] = i__; + } +/* L10: */ + } + --itemp; + +/* Compute the QR factorization and update remaining columns */ + + if (itemp > 0) { + ma = f2cmin(itemp,*m); + sgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info); + if (ma < *n) { + i__1 = *n - ma; + sorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, & + tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info); + } + } + + if (itemp < mn) { + +/* Initialize partial column norms. The first n elements of */ +/* work store the exact column norms. */ + + i__1 = *n; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + i__2 = *m - itemp; + work[i__] = snrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1); + work[*n + i__] = work[i__]; +/* L20: */ + } + +/* Compute factorization */ + + i__1 = mn; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + +/* Determine ith pivot column and swap if necessary */ + + i__2 = *n - i__ + 1; + pvt = i__ - 1 + isamax_(&i__2, &work[i__], &c__1); + + if (pvt != i__) { + sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[i__]; + jpvt[i__] = itemp; + work[pvt] = work[i__]; + work[*n + pvt] = work[*n + i__]; + } + +/* Generate elementary reflector H(i) */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ * + a_dim1], &c__1, &tau[i__]); + } else { + slarfg_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], & + c__1, &tau[*m]); + } + + if (i__ < *n) { + +/* Apply H(i) to A(i:m,i+1:n) from the left */ + + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.f; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + slarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & + tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(* + n << 1) + 1]); + a[i__ + i__ * a_dim1] = aii; + } + +/* Update partial column norms */ + + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (work[j] != 0.f) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)) / work[j]; +/* Computing MAX */ + r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp); + temp = f2cmax(r__1,r__2); +/* Computing 2nd power */ + r__1 = work[j] / work[*n + j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + if (*m - i__ > 0) { + i__3 = *m - i__; + work[j] = snrm2_(&i__3, &a[i__ + 1 + j * a_dim1], + &c__1); + work[*n + j] = work[j]; + } else { + work[j] = 0.f; + work[*n + j] = 0.f; + } + } else { + work[j] *= sqrt(temp); + } + } +/* L30: */ + } + +/* L40: */ + } + } + return 0; + +/* End of SGEQPF */ + +} /* sgeqpf_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/sggsvd.c b/lapack-netlib/SRC/DEPRECATED/sggsvd.c new file mode 100644 index 000000000..b1bc04f9a --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/sggsvd.c @@ -0,0 +1,884 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief SGGSVD computes the singular value decomposition (SVD) for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGGSVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */ +/* LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */ +/* INTEGER IWORK( * ) */ +/* REAL A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), Q( LDQ, * ), U( LDU, * ), */ +/* $ V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine SGGSVD3. */ +/* > */ +/* > SGGSVD computes the generalized singular value decomposition (GSVD) */ +/* > of an M-by-N real matrix A and P-by-N real matrix B: */ +/* > */ +/* > U**T*A*Q = D1*( 0 R ), V**T*B*Q = D2*( 0 R ) */ +/* > */ +/* > where U, V and Q are orthogonal matrices. */ +/* > Let K+L = the effective numerical rank of the matrix (A**T,B**T)**T, */ +/* > then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */ +/* > D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */ +/* > following structures, respectively: */ +/* > */ +/* > If M-K-L >= 0, */ +/* > */ +/* > K L */ +/* > D1 = K ( I 0 ) */ +/* > L ( 0 C ) */ +/* > M-K-L ( 0 0 ) */ +/* > */ +/* > K L */ +/* > D2 = L ( 0 S ) */ +/* > P-L ( 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > ( 0 R ) = K ( 0 R11 R12 ) */ +/* > L ( 0 0 R22 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* > S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R is stored in A(1:K+L,N-K-L+1:N) on exit. */ +/* > */ +/* > If M-K-L < 0, */ +/* > */ +/* > K M-K K+L-M */ +/* > D1 = K ( I 0 0 ) */ +/* > M-K ( 0 C 0 ) */ +/* > */ +/* > K M-K K+L-M */ +/* > D2 = M-K ( 0 S 0 ) */ +/* > K+L-M ( 0 0 I ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K M-K K+L-M */ +/* > ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* > M-K ( 0 0 R22 R23 ) */ +/* > K+L-M ( 0 0 0 R33 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* > S = diag( BETA(K+1), ... , BETA(M) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */ +/* > ( 0 R22 R23 ) */ +/* > in B(M-K+1:L,N+M-K-L+1:N) on exit. */ +/* > */ +/* > The routine computes C, S, R, and optionally the orthogonal */ +/* > transformation matrices U, V and Q. */ +/* > */ +/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */ +/* > A and B implicitly gives the SVD of A*inv(B): */ +/* > A*inv(B) = U*(D1*inv(D2))*V**T. */ +/* > If ( A**T,B**T)**T has orthonormal columns, then the GSVD of A and B is */ +/* > also equal to the CS decomposition of A and B. Furthermore, the GSVD */ +/* > can be used to derive the solution of the eigenvalue problem: */ +/* > A**T*A x = lambda* B**T*B x. */ +/* > In some literature, the GSVD of A and B is presented in the form */ +/* > U**T*A*X = ( 0 D1 ), V**T*B*X = ( 0 D2 ) */ +/* > where U and V are orthogonal and X is nonsingular, D1 and D2 are */ +/* > ``diagonal''. The former GSVD form can be converted to the latter */ +/* > form by taking the nonsingular matrix X as */ +/* > */ +/* > X = Q*( I 0 ) */ +/* > ( 0 inv(R) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Orthogonal matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Orthogonal matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Orthogonal matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \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 matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose. */ +/* > K + L = effective numerical rank of (A**T,B**T)**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular matrix R, or part of R. */ +/* > See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains the triangular matrix R if M-K-L < 0. */ +/* > See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is REAL array, dimension (N) */ +/* > */ +/* > On exit, ALPHA and BETA contain the generalized singular */ +/* > value pairs of A and B; */ +/* > ALPHA(1:K) = 1, */ +/* > BETA(1:K) = 0, */ +/* > and if M-K-L >= 0, */ +/* > ALPHA(K+1:K+L) = C, */ +/* > BETA(K+1:K+L) = S, */ +/* > or if M-K-L < 0, */ +/* > ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */ +/* > BETA(K+1:M) =S, BETA(M+1:K+L) =1 */ +/* > and */ +/* > ALPHA(K+L+1:N) = 0 */ +/* > BETA(K+L+1:N) = 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, */ +/* > dimension (f2cmax(3*N,M,P)+N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > On exit, IWORK stores the sorting information. More */ +/* > precisely, the following loop will sort ALPHA */ +/* > for I = K+1, f2cmin(M,K+L) */ +/* > swap ALPHA(I) and ALPHA(IWORK(I)) */ +/* > endfor */ +/* > such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(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, the Jacobi-type procedure failed to */ +/* > converge. For further details, see subroutine STGSJA. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLA REAL */ +/* > TOLB REAL */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > rank of (A**T,B**T)**T. Generally, they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MACHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERsing */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sggsvd_(char *jobu, char *jobv, char *jobq, integer *m, + integer *n, integer *p, integer *k, integer *l, real *a, integer *lda, + real *b, integer *ldb, real *alpha, real *beta, real *u, integer * + ldu, real *v, integer *ldv, real *q, integer *ldq, real *work, + integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2; + + /* Local variables */ + integer ibnd; + real tola; + integer isub; + real tolb, unfl, temp, smax; + integer ncallmycycle, i__, j; + extern logical lsame_(char *, char *); + real anorm, bnorm; + logical wantq; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + logical wantu, wantv; + extern real slamch_(char *), slange_(char *, integer *, integer *, + real *, integer *, real *); + extern /* Subroutine */ int xerbla_(char *, integer *), stgsja_( + char *, char *, char *, integer *, integer *, integer *, integer * + , integer *, real *, integer *, real *, integer *, real *, real *, + real *, real *, real *, integer *, real *, integer *, real *, + integer *, real *, integer *, integer *), + sggsvp_(char *, char *, char *, integer *, integer *, integer *, + real *, integer *, real *, integer *, real *, real *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , integer *, real *, real *, integer *); + real ulp; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + --iwork; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*p < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -10; + } else if (*ldb < f2cmax(1,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGGSVD", &i__1); + return 0; + } + +/* Compute the Frobenius norm of matrices A and B */ + + anorm = slange_("1", m, n, &a[a_offset], lda, &work[1]); + bnorm = slange_("1", p, n, &b[b_offset], ldb, &work[1]); + +/* Get machine precision and set up threshold for determining */ +/* the effective numerical rank of the matrices A and B. */ + + ulp = slamch_("Precision"); + unfl = slamch_("Safe Minimum"); + tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp; + tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp; + +/* Preprocessing */ + + sggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, & + tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[ + q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], info); + +/* Compute the GSVD of two upper "triangular" matrices */ + + stgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], + ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[ + v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info); + +/* Sort the singular values and store the pivot indices in IWORK */ +/* Copy ALPHA to WORK, then sort ALPHA in WORK */ + + scopy_(n, &alpha[1], &c__1, &work[1], &c__1); +/* Computing MIN */ + i__1 = *l, i__2 = *m - *k; + ibnd = f2cmin(i__1,i__2); + i__1 = ibnd; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for largest ALPHA(K+I) */ + + isub = i__; + smax = work[*k + i__]; + i__2 = ibnd; + for (j = i__ + 1; j <= i__2; ++j) { + temp = work[*k + j]; + if (temp > smax) { + isub = j; + smax = temp; + } +/* L10: */ + } + if (isub != i__) { + work[*k + isub] = work[*k + i__]; + work[*k + i__] = smax; + iwork[*k + i__] = *k + isub; + } else { + iwork[*k + i__] = *k + i__; + } +/* L20: */ + } + + return 0; + +/* End of SGGSVD */ + +} /* sggsvd_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/sggsvp.c b/lapack-netlib/SRC/DEPRECATED/sggsvp.c new file mode 100644 index 000000000..2fd8dad21 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/sggsvp.c @@ -0,0 +1,989 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SGGSVP */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGGSVP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, */ +/* TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, */ +/* IWORK, TAU, WORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */ +/* REAL TOLA, TOLB */ +/* INTEGER IWORK( * ) */ +/* REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine SGGSVP3. */ +/* > */ +/* > SGGSVP computes orthogonal matrices U, V and Q such that */ +/* > */ +/* > N-K-L K L */ +/* > U**T*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* > L ( 0 0 A23 ) */ +/* > M-K-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* > M-K ( 0 0 A23 ) */ +/* > */ +/* > N-K-L K L */ +/* > V**T*B*Q = L ( 0 0 B13 ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* > otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */ +/* > numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. */ +/* > */ +/* > This decomposition is the preprocessing step for computing the */ +/* > Generalized Singular Value Decomposition (GSVD), see subroutine */ +/* > SGGSVD. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Orthogonal matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Orthogonal matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Orthogonal matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular (or trapezoidal) matrix */ +/* > described in the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains the triangular matrix described in */ +/* > the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLA */ +/* > \verbatim */ +/* > TOLA is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLB */ +/* > \verbatim */ +/* > TOLB is REAL */ +/* > */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > numerical rank of matrix B and a subblock of A. Generally, */ +/* > they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MACHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose section. */ +/* > K + L = effective numerical rank of (A**T,B**T)**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the orthogonal matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the orthogonal matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the orthogonal matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (f2cmax(3*N,M,P)) */ +/* > \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 realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > The subroutine uses LAPACK subroutine SGEQPF for the QR factorization */ +/* > with column pivoting to detect the effective numerical rank of the */ +/* > a matrix. It may be replaced by a better rank determination strategy. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m, + integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb, + real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu, + real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real * + tau, real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + logical wantq, wantu, wantv; + extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer + *, real *, real *, integer *), sgerq2_(integer *, integer *, real + *, integer *, real *, real *, integer *), sorg2r_(integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + ), sorm2r_(char *, char *, integer *, integer *, integer *, real * + , integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *, + real *, integer *, real *, real *, integer *, real *, integer *), xerbla_(char *, integer *), sgeqpf_( + integer *, integer *, real *, integer *, integer *, real *, real * + , integer *), slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *), slaset_(char *, integer *, + integer *, real *, real *, real *, integer *), slapmt_( + logical *, integer *, integer *, real *, integer *, integer *); + logical forwrd; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --iwork; + --tau; + --work; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + forwrd = TRUE_; + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -8; + } else if (*ldb < f2cmax(1,*p)) { + *info = -10; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGGSVP", &i__1); + return 0; + } + +/* QR with column pivoting of B: B*P = V*( S11 S12 ) */ +/* ( 0 0 ) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + sgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info); + +/* Update A := A*P */ + + slapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); + +/* Determine the effective rank of matrix B. */ + + *l = 0; + i__1 = f2cmin(*p,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = b[i__ + i__ * b_dim1], abs(r__1)) > *tolb) { + ++(*l); + } +/* L20: */ + } + + if (wantv) { + +/* Copy the details of V, and form V. */ + + slaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv); + if (*p > 1) { + i__1 = *p - 1; + slacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], + ldv); + } + i__1 = f2cmin(*p,*n); + sorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); + } + +/* Clean up B */ + + i__1 = *l - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.f; +/* L30: */ + } +/* L40: */ + } + if (*p > *l) { + i__1 = *p - *l; + slaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb); + } + + if (wantq) { + +/* Set Q = I and Update Q := Q*P */ + + slaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq); + slapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); + } + + if (*p >= *l && *n != *l) { + +/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */ + + sgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); + +/* Update A := A*Z**T */ + + sormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[ + a_offset], lda, &work[1], info); + + if (wantq) { + +/* Update Q := Q*Z**T */ + + sormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1], + &q[q_offset], ldq, &work[1], info); + } + +/* Clean up B */ + + i__1 = *n - *l; + slaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb); + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.f; +/* L50: */ + } +/* L60: */ + } + + } + +/* Let N-L L */ +/* A = ( A11 A12 ) M, */ + +/* then the following does the complete QR decomposition of A11: */ + +/* A11 = U*( 0 T12 )*P1**T */ +/* ( 0 0 ) */ + + i__1 = *n - *l; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L70: */ + } + i__1 = *n - *l; + sgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info); + +/* Determine the effective rank of A11 */ + + *k = 0; +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = a[i__ + i__ * a_dim1], abs(r__1)) > *tola) { + ++(*k); + } +/* L80: */ + } + +/* Update A12 := U**T*A12, where A12 = A( 1:M, N-L+1:N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + sorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[( + *n - *l + 1) * a_dim1 + 1], lda, &work[1], info); + + if (wantu) { + +/* Copy the details of U, and form U */ + + slaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu); + if (*m > 1) { + i__1 = *m - 1; + i__2 = *n - *l; + slacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] + , ldu); + } +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + sorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); + } + + if (wantq) { + +/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ + + i__1 = *n - *l; + slapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); + } + +/* Clean up A: set the strictly lower triangular part of */ +/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L90: */ + } +/* L100: */ + } + if (*m > *k) { + i__1 = *m - *k; + i__2 = *n - *l; + slaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1], + lda); + } + + if (*n - *l > *k) { + +/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ + + i__1 = *n - *l; + sgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); + + if (wantq) { + +/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**T */ + + i__1 = *n - *l; + sormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, & + tau[1], &q[q_offset], ldq, &work[1], info); + } + +/* Clean up A */ + + i__1 = *n - *l - *k; + slaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda); + i__1 = *n - *l; + for (j = *n - *l - *k + 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L110: */ + } +/* L120: */ + } + + } + + if (*m > *k) { + +/* QR factorization of A( K+1:M,N-L+1:N ) */ + + i__1 = *m - *k; + sgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & + work[1], info); + + if (wantu) { + +/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ + + i__1 = *m - *k; +/* Computing MIN */ + i__3 = *m - *k; + i__2 = f2cmin(i__3,*l); + sorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n + - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + + 1], ldu, &work[1], info); + } + +/* Clean up */ + + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L130: */ + } +/* L140: */ + } + + } + + return 0; + +/* End of SGGSVP */ + +} /* sggsvp_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/slahrd.c b/lapack-netlib/SRC/DEPRECATED/slahrd.c new file mode 100644 index 000000000..b2992b04f --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/slahrd.c @@ -0,0 +1,718 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below th +e k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformati +on to the unreduced part of A. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAHRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */ + +/* INTEGER K, LDA, LDT, LDY, N, NB */ +/* REAL A( LDA, * ), T( LDT, NB ), TAU( NB ), */ +/* $ Y( LDY, NB ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine SLAHR2. */ +/* > */ +/* > SLAHRD 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. */ +/* > \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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of columns to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL 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 >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL 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 REAL 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 realOTHERauxiliary */ + +/* > \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 h a a a ) */ +/* > ( a h a a a ) */ +/* > ( a h 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). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slahrd_(integer *n, integer *k, integer *nb, real *a, + integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + real r__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *), scopy_( + integer *, real *, integer *, real *, integer *), saxpy_(integer * + , real *, real *, integer *, real *, integer *), strmv_(char *, + char *, char *, integer *, real *, integer *, real *, integer *); + real ei; + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + 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(1:n,i) */ + +/* Compute i-th column of A - Y * V**T */ + + i__2 = i__ - 1; + sgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k + + i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], & + 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; + scopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + strmv_("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; + sgemv_("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; + strmv_("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; + sgemv_("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; + strmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1] + , lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + saxpy_(&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; + slarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[f2cmin(i__3,*n) + i__ * + a_dim1], &c__1, &tau[i__]); + ei = a[*k + i__ + i__ * a_dim1]; + a[*k + i__ + i__ * a_dim1] = 1.f; + +/* Compute Y(1:n,i) */ + + i__2 = *n - *k - i__ + 1; + sgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ * + y_dim1 + 1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + sgemv_("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 = i__ - 1; + sgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ * + t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1); + sscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1); + +/* Compute T(1:i,i) */ + + i__2 = i__ - 1; + r__1 = -tau[i__]; + sscal_(&i__2, &r__1, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[i__ * t_dim1 + 1], &c__1) + ; + t[i__ + i__ * t_dim1] = tau[i__]; + +/* L10: */ + } + a[*k + *nb + *nb * a_dim1] = ei; + + return 0; + +/* End of SLAHRD */ + +} /* slahrd_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/slatzm.c b/lapack-netlib/SRC/DEPRECATED/slatzm.c new file mode 100644 index 000000000..2c907ceef --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/slatzm.c @@ -0,0 +1,622 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATZM */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLATZM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER INCV, LDC, M, N */ +/* REAL TAU */ +/* REAL C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine SORMRZ. */ +/* > */ +/* > SLATZM applies a Householder matrix generated by STZRQF to a matrix. */ +/* > */ +/* > Let P = I - tau*u*u**T, u = ( 1 ), */ +/* > ( v ) */ +/* > where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */ +/* > SIDE = 'R'. */ +/* > */ +/* > If SIDE equals 'L', let */ +/* > C = [ C1 ] 1 */ +/* > [ C2 ] m-1 */ +/* > n */ +/* > Then C is overwritten by P*C. */ +/* > */ +/* > If SIDE equals 'R', let */ +/* > C = [ C1, C2 ] m */ +/* > 1 n-1 */ +/* > Then C is overwritten by C*P. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form P * C */ +/* > = 'R': form C * P */ +/* > \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 REAL array, dimension */ +/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */ +/* > (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ +/* > The vector v in the representation of P. 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 REAL */ +/* > The value tau in the representation of P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C1 */ +/* > \verbatim */ +/* > C1 is REAL array, dimension */ +/* > (LDC,N) if SIDE = 'L' */ +/* > (M,1) if SIDE = 'R' */ +/* > On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */ +/* > if SIDE = 'R'. */ +/* > */ +/* > On exit, the first row of P*C if SIDE = 'L', or the first */ +/* > column of C*P if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C2 */ +/* > \verbatim */ +/* > C2 is REAL array, dimension */ +/* > (LDC, N) if SIDE = 'L' */ +/* > (LDC, N-1) if SIDE = 'R' */ +/* > On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */ +/* > m x (n - 1) matrix C2 if SIDE = 'R'. */ +/* > */ +/* > On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the arrays C1 and C2. LDC >= (1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > (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 realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slatzm_(char *side, integer *m, integer *n, real *v, + integer *incv, real *tau, real *c1, real *c2, integer *ldc, real * + work) +{ + /* System generated locals */ + integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *), + saxpy_(integer *, real *, real *, integer *, real *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c2_dim1 = *ldc; + c2_offset = 1 + c2_dim1 * 1; + c2 -= c2_offset; + c1_dim1 = *ldc; + c1_offset = 1 + c1_dim1 * 1; + c1 -= c1_offset; + --work; + + /* Function Body */ + if (f2cmin(*m,*n) == 0 || *tau == 0.f) { + return 0; + } + + if (lsame_(side, "L")) { + +/* w := (C1 + v**T * C2)**T */ + + scopy_(n, &c1[c1_offset], ldc, &work[1], &c__1); + i__1 = *m - 1; + sgemv_("Transpose", &i__1, n, &c_b5, &c2[c2_offset], ldc, &v[1], incv, + &c_b5, &work[1], &c__1); + +/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w**T */ +/* [ C2 ] [ C2 ] [ v ] */ + + r__1 = -(*tau); + saxpy_(n, &r__1, &work[1], &c__1, &c1[c1_offset], ldc); + i__1 = *m - 1; + r__1 = -(*tau); + sger_(&i__1, n, &r__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], + ldc); + + } else if (lsame_(side, "R")) { + +/* w := C1 + C2 * v */ + + scopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1); + i__1 = *n - 1; + sgemv_("No transpose", m, &i__1, &c_b5, &c2[c2_offset], ldc, &v[1], + incv, &c_b5, &work[1], &c__1); + +/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**T] */ + + r__1 = -(*tau); + saxpy_(m, &r__1, &work[1], &c__1, &c1[c1_offset], &c__1); + i__1 = *n - 1; + r__1 = -(*tau); + sger_(m, &i__1, &r__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], + ldc); + } + + return 0; + +/* End of SLATZM */ + +} /* slatzm_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/stzrqf.c b/lapack-netlib/SRC/DEPRECATED/stzrqf.c new file mode 100644 index 000000000..d5530e7bf --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/stzrqf.c @@ -0,0 +1,642 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b STZRQF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STZRQF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* REAL A( LDA, * ), TAU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine STZRZF. */ +/* > */ +/* > STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */ +/* > to upper triangular form by means of orthogonal transformations. */ +/* > */ +/* > The upper trapezoidal matrix A is factored as */ +/* > */ +/* > A = ( R 0 ) * Z, */ +/* > */ +/* > where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ +/* > triangular matrix. */ +/* > \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 >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the leading M-by-N upper trapezoidal part of the */ +/* > array A must contain the matrix to be factorized. */ +/* > On exit, the leading M-by-M upper triangular part of A */ +/* > contains the upper triangular matrix R, and elements M+1 to */ +/* > N of the first M rows of A, with the array TAU, represent the */ +/* > orthogonal matrix Z as a product of M elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (M) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \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 realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The factorization is obtained by Householder's method. The kth */ +/* > transformation matrix, Z( k ), which is used to introduce zeros into */ +/* > the ( m - k + 1 )th row of A, is given in the form */ +/* > */ +/* > Z( k ) = ( I 0 ), */ +/* > ( 0 T( k ) ) */ +/* > */ +/* > where */ +/* > */ +/* > T( k ) = I - tau*u( k )*u( k )**T, u( k ) = ( 1 ), */ +/* > ( 0 ) */ +/* > ( z( k ) ) */ +/* > */ +/* > tau is a scalar and z( k ) is an ( n - m ) element vector. */ +/* > tau and z( k ) are chosen to annihilate the elements of the kth row */ +/* > of X. */ +/* > */ +/* > The scalar tau is returned in the kth element of TAU and the vector */ +/* > u( k ) in the kth row of A, such that the elements of z( k ) are */ +/* > in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* > the upper triangular part of A. */ +/* > */ +/* > Z is given by */ +/* > */ +/* > Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stzrqf_(integer *m, integer *n, real *a, integer *lda, + real *tau, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + integer i__, k; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *); + integer m1; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *), xerbla_(char *, integer *), slarfg_( + integer *, real *, real *, integer *, real *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STZRQF", &i__1); + return 0; + } + +/* Perform the factorization. */ + + if (*m == 0) { + return 0; + } + if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.f; +/* L10: */ + } + } else { +/* Computing MIN */ + i__1 = *m + 1; + m1 = f2cmin(i__1,*n); + for (k = *m; k >= 1; --k) { + +/* Use a Householder reflection to zero the kth row of A. */ +/* First set up the reflection. */ + + i__1 = *n - *m + 1; + slarfg_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[ + k]); + + if (tau[k] != 0.f && k > 1) { + +/* We now perform the operation A := A*P( k ). */ + +/* Use the first ( k - 1 ) elements of TAU to store a( k ), */ +/* where a( k ) consists of the first ( k - 1 ) elements of */ +/* the kth column of A. Also let B denote the first */ +/* ( k - 1 ) rows of the last ( n - m ) columns of A. */ + + i__1 = k - 1; + scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1); + +/* Form w = a( k ) + B*z( k ) in TAU. */ + + i__1 = k - 1; + i__2 = *n - *m; + sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 + + 1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], & + c__1); + +/* Now form a( k ) := a( k ) - tau*w */ +/* and B := B - tau*w*z( k )**T. */ + + i__1 = k - 1; + r__1 = -tau[k]; + saxpy_(&i__1, &r__1, &tau[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + i__1 = k - 1; + i__2 = *n - *m; + r__1 = -tau[k]; + sger_(&i__1, &i__2, &r__1, &tau[1], &c__1, &a[k + m1 * a_dim1] + , lda, &a[m1 * a_dim1 + 1], lda); + } +/* L20: */ + } + } + + return 0; + +/* End of STZRQF */ + +} /* stzrqf_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/zgegs.c b/lapack-netlib/SRC/DEPRECATED/zgegs.c new file mode 100644 index 000000000..48eca380a --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/zgegs.c @@ -0,0 +1,1003 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEGS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, */ +/* VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, */ +/* INFO ) */ + +/* CHARACTER JOBVSL, JOBVSR */ +/* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZGGES. */ +/* > */ +/* > ZGEGS computes the eigenvalues, Schur form, and, optionally, the */ +/* > left and or/right Schur vectors of a complex matrix pair (A,B). */ +/* > Given two square matrices A and B, the generalized Schur */ +/* > factorization has the form */ +/* > */ +/* > A = Q*S*Z**H, B = Q*T*Z**H */ +/* > */ +/* > where Q and Z are unitary matrices and S and T are upper triangular. */ +/* > The columns of Q are the left Schur vectors */ +/* > and the columns of Z are the right Schur vectors. */ +/* > */ +/* > If only the eigenvalues of (A,B) are needed, the driver routine */ +/* > ZGEGV should be used instead. See ZGEGV for a description of the */ +/* > eigenvalues of the generalized nonsymmetric eigenvalue problem */ +/* > (GNEP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVSL */ +/* > \verbatim */ +/* > JOBVSL is CHARACTER*1 */ +/* > = 'N': do not compute the left Schur vectors; */ +/* > = 'V': compute the left Schur vectors (returned in VSL). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVSR */ +/* > \verbatim */ +/* > JOBVSR is CHARACTER*1 */ +/* > = 'N': do not compute the right Schur vectors; */ +/* > = 'V': compute the right Schur vectors (returned in VSR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VSL, and VSR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA, N) */ +/* > On entry, the matrix A. */ +/* > On exit, the upper triangular matrix S from the generalized */ +/* > Schur factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB, N) */ +/* > On entry, the matrix B. */ +/* > On exit, the upper triangular matrix T from the generalized */ +/* > Schur factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX*16 array, dimension (N) */ +/* > The complex scalars alpha that define the eigenvalues of */ +/* > GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur */ +/* > form of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX*16 array, dimension (N) */ +/* > The non-negative real scalars beta that define the */ +/* > eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element */ +/* > of the triangular factor T. */ +/* > */ +/* > Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */ +/* > represent the j-th eigenvalue of the matrix pair (A,B), in */ +/* > one of the forms lambda = alpha/beta or mu = beta/alpha. */ +/* > Since either lambda or mu may overflow, they should not, */ +/* > in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSL */ +/* > \verbatim */ +/* > VSL is COMPLEX*16 array, dimension (LDVSL,N) */ +/* > If JOBVSL = 'V', the matrix of left Schur vectors Q. */ +/* > Not referenced if JOBVSL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSL */ +/* > \verbatim */ +/* > LDVSL is INTEGER */ +/* > The leading dimension of the matrix VSL. LDVSL >= 1, and */ +/* > if JOBVSL = 'V', LDVSL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VSR */ +/* > \verbatim */ +/* > VSR is COMPLEX*16 array, dimension (LDVSR,N) */ +/* > If JOBVSR = 'V', the matrix of right Schur vectors Z. */ +/* > Not referenced if JOBVSR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVSR */ +/* > \verbatim */ +/* > LDVSR is INTEGER */ +/* > The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* > if JOBVSR = 'V', LDVSR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 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 >= f2cmax(1,2*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > To compute the optimal value of LWORK, call ILAENV to get */ +/* > blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute: */ +/* > NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR; */ +/* > the optimal LWORK is N*(NB+1). */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION 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. */ +/* > =1,...,N: */ +/* > The QZ iteration failed. (A,B) are not in Schur */ +/* > form, but ALPHA(j) and BETA(j) should be correct for */ +/* > j=INFO+1,...,N. */ +/* > > N: errors that usually indicate LAPACK problems: */ +/* > =N+1: error return from ZGGBAL */ +/* > =N+2: error return from ZGEQRF */ +/* > =N+3: error return from ZUNMQR */ +/* > =N+4: error return from ZUNGQR */ +/* > =N+5: error return from ZGGHRD */ +/* > =N+6: error return from ZHGEQZ (other than failed */ +/* > iteration) */ +/* > =N+7: error return from ZGGBAK (computing VSL) */ +/* > =N+8: error return from ZGGBAK (computing VSR) */ +/* > =N+9: error return from ZLASCL (various places) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int zgegs_(char *jobvsl, char *jobvsr, integer *n, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl, + integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublecomplex * + work, integer *lwork, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2, i__3; + + /* Local variables */ + doublereal anrm, bnrm; + integer itau, lopt; + extern logical lsame_(char *, char *); + integer ileft, iinfo, icols; + logical ilvsl; + integer iwork; + logical ilvsr; + integer irows, nb; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublecomplex *, + integer *, integer *), zggbal_(char *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + , integer *, doublereal *, doublereal *, doublereal *, integer *); + logical ilascl, ilbscl; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + doublereal bignum; + integer ijobvl, iright; + extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + ), zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, integer *); + integer ijobvr; + extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer * + ); + doublereal anrmto; + integer lwkmin, nb1, nb2, nb3; + doublereal bnrmto; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zhgeqz_(char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, integer *), zlaset_(char *, + integer *, integer *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *); + doublereal smlnum; + integer irwork, lwkopt; + logical lquery; + extern /* Subroutine */ int zungqr_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zunmqr_(char *, char *, integer *, integer + *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + integer ihi, ilo; + doublereal eps; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1 * 1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1 * 1; + vsr -= vsr_offset; + --work; + --rwork; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = FALSE_; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = TRUE_; + } else { + ijobvl = -1; + ilvsl = FALSE_; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = FALSE_; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = TRUE_; + } else { + ijobvr = -1; + ilvsr = FALSE_; + } + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 1; + lwkmin = f2cmax(i__1,1); + lwkopt = lwkmin; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -11; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -13; + } else if (*lwork < lwkmin && ! lquery) { + *info = -15; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "ZGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "ZUNMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "ZUNGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); + lopt = *n * (nb + 1); + work[1].r = (doublereal) lopt, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEGS ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("E") * dlamch_("B"); + safmin = dlamch_("S"); + smlnum = *n * safmin / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]); + ilascl = FALSE_; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = TRUE_; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = TRUE_; + } + + if (ilascl) { + zlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]); + ilbscl = FALSE_; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = TRUE_; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = TRUE_; + } + + if (ilbscl) { + zlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ + + ileft = 1; + iright = *n + 1; + irwork = iright + *n; + iwork = 1; + zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[ + ileft], &rwork[iright], &rwork[irwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L10; + } + +/* Reduce B to triangular form, and initialize VSL and/or VSR */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwork; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L10; + } + + i__1 = *lwork + 1 - iwork; + zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L10; + } + + if (ilvsl) { + zlaset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl); + i__1 = irows - 1; + i__2 = irows - 1; + zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo + + 1 + ilo * vsl_dim1], ldvsl); + i__1 = *lwork + 1 - iwork; + zungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L10; + } + } + + if (ilvsr) { + zlaset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ + + zgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 5; + goto L10; + } + +/* Perform QZ algorithm, computing Schur vectors if desired */ + + iwork = itau; + i__1 = *lwork + 1 - iwork; + zhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, & + vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &rwork[irwork], & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L10; + } + +/* Apply permutation to VSL and VSR */ + + if (ilvsl) { + zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, & + vsl[vsl_offset], ldvsl, &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L10; + } + } + if (ilvsr) { + zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, & + vsr[vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L10; + } + } + +/* Undo scaling */ + + if (ilascl) { + zlascl_("U", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + zlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alpha[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + + if (ilbscl) { + zlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + zlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +L10: + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + + return 0; + +/* End of ZGEGS */ + +} /* zgegs_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/zgegv.c b/lapack-netlib/SRC/DEPRECATED/zgegv.c new file mode 100644 index 000000000..0c85af030 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/zgegv.c @@ -0,0 +1,1234 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, */ +/* VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) */ + +/* CHARACTER JOBVL, JOBVR */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZGGEV. */ +/* > */ +/* > ZGEGV computes the eigenvalues and, optionally, the left and/or right */ +/* > eigenvectors of a complex matrix pair (A,B). */ +/* > Given two square matrices A and B, */ +/* > the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */ +/* > eigenvalues lambda and corresponding (non-zero) eigenvectors x such */ +/* > that */ +/* > A*x = lambda*B*x. */ +/* > */ +/* > An alternate form is to find the eigenvalues mu and corresponding */ +/* > eigenvectors y such that */ +/* > mu*A*y = B*y. */ +/* > */ +/* > These two forms are equivalent with mu = 1/lambda and x = y if */ +/* > neither lambda nor mu is zero. In order to deal with the case that */ +/* > lambda or mu is zero or small, two values alpha and beta are returned */ +/* > for each eigenvalue, such that lambda = alpha/beta and */ +/* > mu = beta/alpha. */ +/* > */ +/* > The vectors x and y in the above equations are right eigenvectors of */ +/* > the matrix pair (A,B). Vectors u and v satisfying */ +/* > u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */ +/* > are left eigenvectors of (A,B). */ +/* > */ +/* > Note: this routine performs "full balancing" on A and B */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': do not compute the left generalized eigenvectors; */ +/* > = 'V': compute the left generalized eigenvectors (returned */ +/* > in VL). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': do not compute the right generalized eigenvectors; */ +/* > = 'V': compute the right generalized eigenvectors (returned */ +/* > in VR). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A, B, VL, and VR. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA, N) */ +/* > On entry, the matrix A. */ +/* > If JOBVL = 'V' or JOBVR = 'V', then on exit A */ +/* > contains the Schur form of A from the generalized Schur */ +/* > factorization of the pair (A,B) after balancing. If no */ +/* > eigenvectors were computed, then only the diagonal elements */ +/* > of the Schur form will be correct. See ZGGHRD and ZHGEQZ */ +/* > for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB, N) */ +/* > On entry, the matrix B. */ +/* > If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */ +/* > upper triangular matrix obtained from B in the generalized */ +/* > Schur factorization of the pair (A,B) after balancing. */ +/* > If no eigenvectors were computed, then only the diagonal */ +/* > elements of B will be correct. See ZGGHRD and ZHGEQZ for */ +/* > details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX*16 array, dimension (N) */ +/* > The complex scalars alpha that define the eigenvalues of */ +/* > GNEP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX*16 array, dimension (N) */ +/* > The complex scalars beta that define the eigenvalues of GNEP. */ +/* > */ +/* > Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */ +/* > represent the j-th eigenvalue of the matrix pair (A,B), in */ +/* > one of the forms lambda = alpha/beta or mu = beta/alpha. */ +/* > Since either lambda or mu may overflow, they should not, */ +/* > in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is COMPLEX*16 array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored */ +/* > in the columns of VL, in the same order as their eigenvalues. */ +/* > Each eigenvector is scaled so that its largest component has */ +/* > abs(real part) + abs(imag. part) = 1, except for eigenvectors */ +/* > corresponding to an eigenvalue with alpha = beta = 0, which */ +/* > are set to zero. */ +/* > Not referenced if JOBVL = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the matrix VL. LDVL >= 1, and */ +/* > if JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is COMPLEX*16 array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors x(j) are stored */ +/* > in the columns of VR, in the same order as their eigenvalues. */ +/* > Each eigenvector is scaled so that its largest component has */ +/* > abs(real part) + abs(imag. part) = 1, except for eigenvectors */ +/* > corresponding to an eigenvalue with alpha = beta = 0, which */ +/* > are set to zero. */ +/* > Not referenced if JOBVR = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the matrix VR. LDVR >= 1, and */ +/* > if JOBVR = 'V', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 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 >= f2cmax(1,2*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > To compute the optimal value of LWORK, call ILAENV to get */ +/* > blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.) Then compute: */ +/* > NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR; */ +/* > The optimal LWORK is MAX( 2*N, N*(NB+1) ). */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION 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. */ +/* > =1,...,N: */ +/* > The QZ iteration failed. No eigenvectors have been */ +/* > calculated, but ALPHA(j) and BETA(j) should be */ +/* > correct for j=INFO+1,...,N. */ +/* > > N: errors that usually indicate LAPACK problems: */ +/* > =N+1: error return from ZGGBAL */ +/* > =N+2: error return from ZGEQRF */ +/* > =N+3: error return from ZUNMQR */ +/* > =N+4: error return from ZUNGQR */ +/* > =N+5: error return from ZGGHRD */ +/* > =N+6: error return from ZHGEQZ (other than failed */ +/* > iteration) */ +/* > =N+7: error return from ZTGEVC */ +/* > =N+8: error return from ZGGBAK (computing VL) */ +/* > =N+9: error return from ZGGBAK (computing VR) */ +/* > =N+10: error return from ZLASCL (various calls) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEeigen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Balancing */ +/* > --------- */ +/* > */ +/* > This driver calls ZGGBAL to both permute and scale rows and columns */ +/* > of A and B. The permutations PL and PR are chosen so that PL*A*PR */ +/* > and PL*B*R will be upper triangular except for the diagonal blocks */ +/* > A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */ +/* > possible. The diagonal scaling matrices DL and DR are chosen so */ +/* > that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */ +/* > one (except for the elements that start out zero.) */ +/* > */ +/* > After the eigenvalues and eigenvectors of the balanced matrices */ +/* > have been computed, ZGGBAK transforms the eigenvectors back to what */ +/* > they would have been (in perfect arithmetic) if they had not been */ +/* > balanced. */ +/* > */ +/* > Contents of A and B on Exit */ +/* > -------- -- - --- - -- ---- */ +/* > */ +/* > If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */ +/* > both), then on exit the arrays A and B will contain the complex Schur */ +/* > form[*] of the "balanced" versions of A and B. If no eigenvectors */ +/* > are computed, then only the diagonal blocks will be correct. */ +/* > */ +/* > [*] In other words, upper triangular form. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgegv_(char *jobvl, char *jobvr, integer *n, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer + *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer + *lwork, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1, z__2; + + /* Local variables */ + doublereal absb, anrm, bnrm; + integer itau; + doublereal temp; + logical ilvl, ilvr; + integer lopt; + doublereal anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta; + extern logical lsame_(char *, char *); + integer ileft, iinfo, icols, iwork, irows, jc, nb, in; + extern doublereal dlamch_(char *); + integer jr; + doublereal salfai; + extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublecomplex *, + integer *, integer *), zggbal_(char *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + , integer *, doublereal *, doublereal *, doublereal *, integer *); + doublereal salfar, safmin; + extern /* Subroutine */ int xerbla_(char *, integer *); + doublereal safmax; + char chtemp[1]; + logical ldumma[1]; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + integer ijobvl, iright; + logical ilimit; + extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + ), zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, integer *); + integer ijobvr; + extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer * + ); + integer lwkmin, nb1, nb2, nb3; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zlaset_(char *, integer *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *), ztgevc_( + char *, char *, logical *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, integer *, doublecomplex *, + doublereal *, integer *), zhgeqz_(char *, char *, + char *, integer *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, doublereal *, integer *); + integer irwork, lwkopt; + logical lquery; + extern /* Subroutine */ int zungqr_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zunmqr_(char *, char *, integer *, integer + *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + integer ihi, ilo; + doublereal eps; + logical ilv; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + --rwork; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = FALSE_; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = TRUE_; + } else { + ijobvl = -1; + ilvl = FALSE_; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = FALSE_; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = TRUE_; + } else { + ijobvr = -1; + ilvr = FALSE_; + } + ilv = ilvl || ilvr; + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 1; + lwkmin = f2cmax(i__1,1); + lwkopt = lwkmin; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -11; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -13; + } else if (*lwork < lwkmin && ! lquery) { + *info = -15; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "ZGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "ZUNMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "ZUNGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( + ftnlen)1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2); + nb = f2cmax(i__1,nb3); +/* Computing MAX */ + i__1 = *n << 1, i__2 = *n * (nb + 1); + lopt = f2cmax(i__1,i__2); + work[1].r = (doublereal) lopt, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEGV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("E") * dlamch_("B"); + safmin = dlamch_("S"); + safmin += safmin; + safmax = 1. / safmin; + +/* Scale A */ + + anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]); + anrm1 = anrm; + anrm2 = 1.; + if (anrm < 1.) { + if (safmax * anrm < 1.) { + anrm1 = safmin; + anrm2 = safmax * anrm; + } + } + + if (anrm > 0.) { + zlascl_("G", &c_n1, &c_n1, &anrm, &c_b29, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Scale B */ + + bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]); + bnrm1 = bnrm; + bnrm2 = 1.; + if (bnrm < 1.) { + if (safmax * bnrm < 1.) { + bnrm1 = safmin; + bnrm2 = safmax * bnrm; + } + } + + if (bnrm > 0.) { + zlascl_("G", &c_n1, &c_n1, &bnrm, &c_b29, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ +/* Also "balance" the matrix. */ + + ileft = 1; + iright = *n + 1; + irwork = iright + *n; + zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[ + ileft], &rwork[iright], &rwork[irwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L80; + } + +/* Reduce B to triangular form, and initialize VL and/or VR */ + + irows = ihi + 1 - ilo; + if (ilv) { + icols = *n + 1 - ilo; + } else { + icols = irows; + } + itau = 1; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L80; + } + + i__1 = *lwork + 1 - iwork; + zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L80; + } + + if (ilvl) { + zlaset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl); + i__1 = irows - 1; + i__2 = irows - 1; + zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo + + 1 + ilo * vl_dim1], ldvl); + i__1 = *lwork + 1 - iwork; + zungqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ + itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L80; + } + } + + if (ilvr) { + zlaset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr); + } + +/* Reduce to generalized Hessenberg form */ + + if (ilv) { + +/* Eigenvectors requested -- work on whole matrix. */ + + zgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo); + } else { + zgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, + &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &iinfo); + } + if (iinfo != 0) { + *info = *n + 5; + goto L80; + } + +/* Perform QZ algorithm */ + + iwork = itau; + if (ilv) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + i__1 = *lwork + 1 - iwork; + zhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &work[iwork], &i__1, &rwork[irwork], &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__3 = iwork; + i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; + lwkopt = f2cmax(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L80; + } + + if (ilv) { + +/* Compute Eigenvectors */ + + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + + ztgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, + &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ + iwork], &rwork[irwork], &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L80; + } + +/* Undo balancing on VL and VR, rescale */ + + if (ilvl) { + zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, + &vl[vl_offset], ldvl, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L80; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + temp = 0.; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + i__3 = jr + jc * vl_dim1; + d__3 = temp, d__4 = (d__1 = vl[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&vl[jr + jc * vl_dim1]), abs(d__2)); + temp = f2cmax(d__3,d__4); +/* L10: */ + } + if (temp < safmin) { + goto L30; + } + temp = 1. / temp; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + i__3 = jr + jc * vl_dim1; + i__4 = jr + jc * vl_dim1; + z__1.r = temp * vl[i__4].r, z__1.i = temp * vl[i__4].i; + vl[i__3].r = z__1.r, vl[i__3].i = z__1.i; +/* L20: */ + } +L30: + ; + } + } + if (ilvr) { + zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, + &vr[vr_offset], ldvr, &iinfo); + if (iinfo != 0) { + *info = *n + 9; + goto L80; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + temp = 0.; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + i__3 = jr + jc * vr_dim1; + d__3 = temp, d__4 = (d__1 = vr[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&vr[jr + jc * vr_dim1]), abs(d__2)); + temp = f2cmax(d__3,d__4); +/* L40: */ + } + if (temp < safmin) { + goto L60; + } + temp = 1. / temp; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + i__3 = jr + jc * vr_dim1; + i__4 = jr + jc * vr_dim1; + z__1.r = temp * vr[i__4].r, z__1.i = temp * vr[i__4].i; + vr[i__3].r = z__1.r, vr[i__3].i = z__1.i; +/* L50: */ + } +L60: + ; + } + } + +/* End of eigenvector calculation */ + + } + +/* Undo scaling in alpha, beta */ + +/* Note: this does not give the alpha and beta for the unscaled */ +/* problem. */ + +/* Un-scaling is limited to avoid underflow in alpha and beta */ +/* if they are significant. */ + + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = jc; + absar = (d__1 = alpha[i__2].r, abs(d__1)); + absai = (d__1 = d_imag(&alpha[jc]), abs(d__1)); + i__2 = jc; + absb = (d__1 = beta[i__2].r, abs(d__1)); + i__2 = jc; + salfar = anrm * alpha[i__2].r; + salfai = anrm * d_imag(&alpha[jc]); + i__2 = jc; + sbeta = bnrm * beta[i__2].r; + ilimit = FALSE_; + scale = 1.; + +/* Check for significant underflow in imaginary part of ALPHA */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absar, d__1 = f2cmax(d__1,d__2), d__2 = eps * + absb; + if (abs(salfai) < safmin && absai >= f2cmax(d__1,d__2)) { + ilimit = TRUE_; +/* Computing MAX */ + d__1 = safmin, d__2 = anrm2 * absai; + scale = safmin / anrm1 / f2cmax(d__1,d__2); + } + +/* Check for significant underflow in real part of ALPHA */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absai, d__1 = f2cmax(d__1,d__2), d__2 = eps * + absb; + if (abs(salfar) < safmin && absar >= f2cmax(d__1,d__2)) { + ilimit = TRUE_; +/* Computing MAX */ +/* Computing MAX */ + d__3 = safmin, d__4 = anrm2 * absar; + d__1 = scale, d__2 = safmin / anrm1 / f2cmax(d__3,d__4); + scale = f2cmax(d__1,d__2); + } + +/* Check for significant underflow in BETA */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absar, d__1 = f2cmax(d__1,d__2), d__2 = eps * + absai; + if (abs(sbeta) < safmin && absb >= f2cmax(d__1,d__2)) { + ilimit = TRUE_; +/* Computing MAX */ +/* Computing MAX */ + d__3 = safmin, d__4 = bnrm2 * absb; + d__1 = scale, d__2 = safmin / bnrm1 / f2cmax(d__3,d__4); + scale = f2cmax(d__1,d__2); + } + +/* Check for possible overflow when limiting scaling */ + + if (ilimit) { +/* Computing MAX */ + d__1 = abs(salfar), d__2 = abs(salfai), d__1 = f2cmax(d__1,d__2), + d__2 = abs(sbeta); + temp = scale * safmin * f2cmax(d__1,d__2); + if (temp > 1.) { + scale /= temp; + } + if (scale < 1.) { + ilimit = FALSE_; + } + } + +/* Recompute un-scaled ALPHA, BETA if necessary. */ + + if (ilimit) { + i__2 = jc; + salfar = scale * alpha[i__2].r * anrm; + salfai = scale * d_imag(&alpha[jc]) * anrm; + i__2 = jc; + z__2.r = scale * beta[i__2].r, z__2.i = scale * beta[i__2].i; + z__1.r = bnrm * z__2.r, z__1.i = bnrm * z__2.i; + sbeta = z__1.r; + } + i__2 = jc; + z__1.r = salfar, z__1.i = salfai; + alpha[i__2].r = z__1.r, alpha[i__2].i = z__1.i; + i__2 = jc; + beta[i__2].r = sbeta, beta[i__2].i = 0.; +/* L70: */ + } + +L80: + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + + return 0; + +/* End of ZGEGV */ + +} /* zgegv_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/zgelsx.c b/lapack-netlib/SRC/DEPRECATED/zgelsx.c new file mode 100644 index 000000000..4689c3555 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/zgelsx.c @@ -0,0 +1,908 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief ZGELSX solves overdetermined or underdetermined systems for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGELSX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */ +/* WORK, RWORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, M, N, NRHS, RANK */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER JPVT( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZGELSY. */ +/* > */ +/* > ZGELSX computes the minimum-norm solution to a complex linear least */ +/* > squares problem: */ +/* > minimize || A * X - B || */ +/* > using a complete orthogonal factorization of A. A is an M-by-N */ +/* > matrix which may be rank-deficient. */ +/* > */ +/* > Several right hand side vectors b and solution vectors x can be */ +/* > handled in a single call; they are stored as the columns of the */ +/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* > matrix X. */ +/* > */ +/* > The routine first computes a QR factorization with column pivoting: */ +/* > A * P = Q * [ R11 R12 ] */ +/* > [ 0 R22 ] */ +/* > with R11 defined as the largest leading submatrix whose estimated */ +/* > condition number is less than 1/RCOND. The order of R11, RANK, */ +/* > is the effective rank of A. */ +/* > */ +/* > Then, R22 is considered to be negligible, and R12 is annihilated */ +/* > by unitary transformations from the right, arriving at the */ +/* > complete orthogonal factorization: */ +/* > A * P = Q * [ T11 0 ] * Z */ +/* > [ 0 0 ] */ +/* > The minimum-norm solution is then */ +/* > X = P * Z**H [ inv(T11)*Q1**H*B ] */ +/* > [ 0 ] */ +/* > where Q1 consists of the first RANK columns of Q. */ +/* > \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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of */ +/* > columns of matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A has been overwritten by details of its */ +/* > complete orthogonal factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the M-by-NRHS right hand side matrix B. */ +/* > On exit, the N-by-NRHS solution matrix X. */ +/* > If m >= n and RANK = n, the residual sum-of-squares for */ +/* > the solution in the i-th column is given by the sum of */ +/* > squares of elements N+1:M in that column. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is an */ +/* > initial column, otherwise it is a free column. Before */ +/* > the QR factorization of A, all initial columns are */ +/* > permuted to the leading positions; only the remaining */ +/* > free columns are moved as a result of column pivoting */ +/* > during the factorization. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > RCOND is used to determine the effective rank of A, which */ +/* > is defined as the order of the largest leading triangular */ +/* > submatrix R11 in the QR factorization with pivoting of A, */ +/* > whose estimated condition number < 1/RCOND. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The effective rank of A, i.e., the order of the submatrix */ +/* > R11. This is the same as the order of the submatrix T11 */ +/* > in the complete orthogonal factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension */ +/* > (f2cmin(M,N) + f2cmax( N, 2*f2cmin(M,N)+NRHS )), */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*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 complex16GEsolve */ + +/* ===================================================================== */ +/* Subroutine */ int zgelsx_(integer *m, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, + doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + doublecomplex z__1; + + /* Local variables */ + doublereal anrm, bnrm, smin, smax; + integer i__, j, k, iascl, ibscl, ismin, ismax; + doublecomplex c1, c2, s1, s2, t1, t2; + extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), + zlaic1_(integer *, integer *, doublecomplex *, doublereal *, + doublecomplex *, doublecomplex *, doublereal *, doublecomplex *, + doublecomplex *), dlabad_(doublereal *, doublereal *); + extern doublereal dlamch_(char *); + integer mn; + extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + doublereal bignum; + extern /* Subroutine */ int zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, integer *), zgeqpf_(integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *), zlaset_(char *, + integer *, integer *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *); + doublereal sminpr, smaxpr, smlnum; + extern /* Subroutine */ int zlatzm_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *), ztzrqf_( + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *); + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --jpvt; + --work; + --rwork; + + /* Function Body */ + mn = f2cmin(*m,*n); + ismin = mn + 1; + ismax = (mn << 1) + 1; + +/* Test the input arguments. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*m); + if (*ldb < f2cmax(i__1,*n)) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELSX", &i__1); + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*nrhs) == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S") / dlamch_("P"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A, B if f2cmax elements outside range [SMLNUM,BIGNUM] */ + + anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = f2cmax(*m,*n); + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + *rank = 0; + goto L100; + } + + bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Compute QR factorization with column pivoting of A: */ +/* A * P = Q * R */ + + zgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], & + rwork[1], info); + +/* complex workspace MN+N. Real workspace 2*N. Details of Householder */ +/* rotations stored in WORK(1:MN). */ + +/* Determine RANK using incremental condition estimation */ + + i__1 = ismin; + work[i__1].r = 1., work[i__1].i = 0.; + i__1 = ismax; + work[i__1].r = 1., work[i__1].i = 0.; + smax = z_abs(&a[a_dim1 + 1]); + smin = smax; + if (z_abs(&a[a_dim1 + 1]) == 0.) { + *rank = 0; + i__1 = f2cmax(*m,*n); + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + goto L100; + } else { + *rank = 1; + } + +L10: + if (*rank < mn) { + i__ = *rank + 1; + zlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &sminpr, &s1, &c1); + zlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &smaxpr, &s2, &c2); + + if (smaxpr * *rcond <= sminpr) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ismin + i__ - 1; + i__3 = ismin + i__ - 1; + z__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, z__1.i = + s1.r * work[i__3].i + s1.i * work[i__3].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = ismax + i__ - 1; + i__3 = ismax + i__ - 1; + z__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, z__1.i = + s2.r * work[i__3].i + s2.i * work[i__3].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; +/* L20: */ + } + i__1 = ismin + *rank; + work[i__1].r = c1.r, work[i__1].i = c1.i; + i__1 = ismax + *rank; + work[i__1].r = c2.r, work[i__1].i = c2.i; + smin = sminpr; + smax = smaxpr; + ++(*rank); + goto L10; + } + } + +/* Logically partition R = [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* where R11 = R(1:RANK,1:RANK) */ + +/* [R11,R12] = [ T11, 0 ] * Y */ + + if (*rank < *n) { + ztzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info); + } + +/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ + +/* B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS) */ + + zunm2r_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, & + work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], info); + +/* workspace NRHS */ + +/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ + + ztrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[ + a_offset], lda, &b[b_offset], ldb); + + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Y**H * B(1:N,1:NRHS) */ + + if (*rank < *n) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - *rank + 1; + d_cnjg(&z__1, &work[mn + i__]); + zlatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, + &z__1, &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], ldb, & + work[(mn << 1) + 1]); +/* L50: */ + } + } + +/* workspace NRHS */ + +/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = (mn << 1) + i__; + work[i__3].r = 1., work[i__3].i = 0.; +/* L60: */ + } + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = (mn << 1) + i__; + if (work[i__3].r == 1. && work[i__3].i == 0.) { + if (jpvt[i__] != i__) { + k = i__; + i__3 = k + j * b_dim1; + t1.r = b[i__3].r, t1.i = b[i__3].i; + i__3 = jpvt[k] + j * b_dim1; + t2.r = b[i__3].r, t2.i = b[i__3].i; +L70: + i__3 = jpvt[k] + j * b_dim1; + b[i__3].r = t1.r, b[i__3].i = t1.i; + i__3 = (mn << 1) + k; + work[i__3].r = 0., work[i__3].i = 0.; + t1.r = t2.r, t1.i = t2.i; + k = jpvt[k]; + i__3 = jpvt[k] + j * b_dim1; + t2.r = b[i__3].r, t2.i = b[i__3].i; + if (jpvt[k] != i__) { + goto L70; + } + i__3 = i__ + j * b_dim1; + b[i__3].r = t1.r, b[i__3].i = t1.i; + i__3 = (mn << 1) + k; + work[i__3].r = 0., work[i__3].i = 0.; + } + } +/* L80: */ + } +/* L90: */ + } + +/* Undo scaling */ + + if (iascl == 1) { + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + zlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], + lda, info); + } else if (iascl == 2) { + zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + zlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], + lda, info); + } + if (ibscl == 1) { + zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L100: + + return 0; + +/* End of ZGELSX */ + +} /* zgelsx_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/zgeqpf.c b/lapack-netlib/SRC/DEPRECATED/zgeqpf.c new file mode 100644 index 000000000..d900d0880 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/zgeqpf.c @@ -0,0 +1,745 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZGEQPF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQPF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* INTEGER JPVT( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZGEQP3. */ +/* > */ +/* > ZGEQPF computes a QR factorization with column pivoting of a */ +/* > complex M-by-N matrix A: A*P = Q*R. */ +/* > \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 COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the upper triangle of the array contains the */ +/* > f2cmin(M,N)-by-N upper triangular matrix R; the elements */ +/* > below the diagonal, together with the array TAU, */ +/* > represent the unitary matrix Q as a product of */ +/* > f2cmin(m,n) elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */ +/* > to the front of A*P (a leading column); if JPVT(i) = 0, */ +/* > the i-th column of A is a free column. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*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 complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(n) */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex 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). */ +/* > */ +/* > The matrix P is represented in jpvt as follows: If */ +/* > jpvt(j) = i */ +/* > then the jth column of P is the ith canonical unit vector. */ +/* > */ +/* > Partial column norm updating strategy modified by */ +/* > Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* > University of Zagreb, Croatia. */ +/* > -- April 2011 -- */ +/* > For more details see LAPACK Working Note 176. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a, + integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work, + doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + doublereal temp, temp2; + integer i__, j; + doublereal tol3z; + integer itemp; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), zswap_(integer *, + doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_( + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + integer ma; + extern doublereal dlamch_(char *); + integer mn; + extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_( + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *); + doublecomplex aii; + integer pvt; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --jpvt; + --tau; + --work; + --rwork; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQPF", &i__1); + return 0; + } + + mn = f2cmin(*m,*n); + tol3z = sqrt(dlamch_("Epsilon")); + +/* Move initial columns up front */ + + itemp = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (jpvt[i__] != 0) { + if (i__ != itemp) { + zswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1], + &c__1); + jpvt[i__] = jpvt[itemp]; + jpvt[itemp] = i__; + } else { + jpvt[i__] = i__; + } + ++itemp; + } else { + jpvt[i__] = i__; + } +/* L10: */ + } + --itemp; + +/* Compute the QR factorization and update remaining columns */ + + if (itemp > 0) { + ma = f2cmin(itemp,*m); + zgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info); + if (ma < *n) { + i__1 = *n - ma; + zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset] + , lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], + info); + } + } + + if (itemp < mn) { + +/* Initialize partial column norms. The first n elements of */ +/* work store the exact column norms. */ + + i__1 = *n; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + i__2 = *m - itemp; + rwork[i__] = dznrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1); + rwork[*n + i__] = rwork[i__]; +/* L20: */ + } + +/* Compute factorization */ + + i__1 = mn; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + +/* Determine ith pivot column and swap if necessary */ + + i__2 = *n - i__ + 1; + pvt = i__ - 1 + idamax_(&i__2, &rwork[i__], &c__1); + + if (pvt != i__) { + zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[i__]; + jpvt[i__] = itemp; + rwork[pvt] = rwork[i__]; + rwork[*n + pvt] = rwork[*n + i__]; + } + +/* Generate elementary reflector H(i) */ + + i__2 = i__ + i__ * a_dim1; + aii.r = a[i__2].r, aii.i = a[i__2].i; + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + zlarfg_(&i__2, &aii, &a[f2cmin(i__3,*m) + i__ * a_dim1], &c__1, &tau[ + i__]); + i__2 = i__ + i__ * a_dim1; + a[i__2].r = aii.r, a[i__2].i = aii.i; + + if (i__ < *n) { + +/* Apply H(i) to A(i:m,i+1:n) from the left */ + + i__2 = i__ + i__ * a_dim1; + aii.r = a[i__2].r, aii.i = a[i__2].i; + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + d_cnjg(&z__1, &tau[i__]); + zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & + z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); + i__2 = i__ + i__ * a_dim1; + a[i__2].r = aii.r, a[i__2].i = aii.i; + } + +/* Update partial column norms */ + + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (rwork[j] != 0.) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = z_abs(&a[i__ + j * a_dim1]) / rwork[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = f2cmax(d__1,d__2); +/* Computing 2nd power */ + d__1 = rwork[j] / rwork[*n + j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + if (*m - i__ > 0) { + i__3 = *m - i__; + rwork[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1] + , &c__1); + rwork[*n + j] = rwork[j]; + } else { + rwork[j] = 0.; + rwork[*n + j] = 0.; + } + } else { + rwork[j] *= sqrt(temp); + } + } +/* L30: */ + } + +/* L40: */ + } + } + return 0; + +/* End of ZGEQPF */ + +} /* zgeqpf_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/zggsvd.c b/lapack-netlib/SRC/DEPRECATED/zggsvd.c new file mode 100644 index 000000000..e2cfb69f0 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/zggsvd.c @@ -0,0 +1,892 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief ZGGSVD computes the singular value decomposition (SVD) for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGGSVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */ +/* LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */ +/* RWORK, IWORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION ALPHA( * ), BETA( * ), RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ U( LDU, * ), V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZGGSVD3. */ +/* > */ +/* > ZGGSVD computes the generalized singular value decomposition (GSVD) */ +/* > of an M-by-N complex matrix A and P-by-N complex matrix B: */ +/* > */ +/* > U**H*A*Q = D1*( 0 R ), V**H*B*Q = D2*( 0 R ) */ +/* > */ +/* > where U, V and Q are unitary matrices. */ +/* > Let K+L = the effective numerical rank of the */ +/* > matrix (A**H,B**H)**H, then R is a (K+L)-by-(K+L) nonsingular upper */ +/* > triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal" */ +/* > matrices and of the following structures, respectively: */ +/* > */ +/* > If M-K-L >= 0, */ +/* > */ +/* > K L */ +/* > D1 = K ( I 0 ) */ +/* > L ( 0 C ) */ +/* > M-K-L ( 0 0 ) */ +/* > */ +/* > K L */ +/* > D2 = L ( 0 S ) */ +/* > P-L ( 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > ( 0 R ) = K ( 0 R11 R12 ) */ +/* > L ( 0 0 R22 ) */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* > S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R is stored in A(1:K+L,N-K-L+1:N) on exit. */ +/* > */ +/* > If M-K-L < 0, */ +/* > */ +/* > K M-K K+L-M */ +/* > D1 = K ( I 0 0 ) */ +/* > M-K ( 0 C 0 ) */ +/* > */ +/* > K M-K K+L-M */ +/* > D2 = M-K ( 0 S 0 ) */ +/* > K+L-M ( 0 0 I ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K M-K K+L-M */ +/* > ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* > M-K ( 0 0 R22 R23 ) */ +/* > K+L-M ( 0 0 0 R33 ) */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* > S = diag( BETA(K+1), ... , BETA(M) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */ +/* > ( 0 R22 R23 ) */ +/* > in B(M-K+1:L,N+M-K-L+1:N) on exit. */ +/* > */ +/* > The routine computes C, S, R, and optionally the unitary */ +/* > transformation matrices U, V and Q. */ +/* > */ +/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */ +/* > A and B implicitly gives the SVD of A*inv(B): */ +/* > A*inv(B) = U*(D1*inv(D2))*V**H. */ +/* > If ( A**H,B**H)**H has orthnormal columns, then the GSVD of A and B is also */ +/* > equal to the CS decomposition of A and B. Furthermore, the GSVD can */ +/* > be used to derive the solution of the eigenvalue problem: */ +/* > A**H*A x = lambda* B**H*B x. */ +/* > In some literature, the GSVD of A and B is presented in the form */ +/* > U**H*A*X = ( 0 D1 ), V**H*B*X = ( 0 D2 ) */ +/* > where U and V are orthogonal and X is nonsingular, and D1 and D2 are */ +/* > ``diagonal''. The former GSVD form can be converted to the latter */ +/* > form by taking the nonsingular matrix X as */ +/* > */ +/* > X = Q*( I 0 ) */ +/* > ( 0 inv(R) ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Unitary matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Unitary matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Unitary matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \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 matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose. */ +/* > K + L = effective numerical rank of (A**H,B**H)**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular matrix R, or part of R. */ +/* > See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains part of the triangular matrix R if */ +/* > M-K-L < 0. See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > On exit, ALPHA and BETA contain the generalized singular */ +/* > value pairs of A and B; */ +/* > ALPHA(1:K) = 1, */ +/* > BETA(1:K) = 0, */ +/* > and if M-K-L >= 0, */ +/* > ALPHA(K+1:K+L) = C, */ +/* > BETA(K+1:K+L) = S, */ +/* > or if M-K-L < 0, */ +/* > ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */ +/* > BETA(K+1:M) =S, BETA(M+1:K+L) =1 */ +/* > and */ +/* > ALPHA(K+L+1:N) = 0 */ +/* > BETA(K+L+1:N) = 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is COMPLEX*16 array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the M-by-M unitary matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the P-by-P unitary matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX*16 array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (f2cmax(3*N,M,P)+N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > On exit, IWORK stores the sorting information. More */ +/* > precisely, the following loop will sort ALPHA */ +/* > for I = K+1, f2cmin(M,K+L) */ +/* > swap ALPHA(I) and ALPHA(IWORK(I)) */ +/* > endfor */ +/* > such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(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, the Jacobi-type procedure failed to */ +/* > converge. For further details, see subroutine ZTGSJA. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLA DOUBLE PRECISION */ +/* > TOLB DOUBLE PRECISION */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > rank of (A**H,B**H)**H. Generally, they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MAZHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MAZHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERsing */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zggsvd_(char *jobu, char *jobv, char *jobq, integer *m, + integer *n, integer *p, integer *k, integer *l, doublecomplex *a, + integer *lda, doublecomplex *b, integer *ldb, doublereal *alpha, + doublereal *beta, doublecomplex *u, integer *ldu, doublecomplex *v, + integer *ldv, doublecomplex *q, integer *ldq, doublecomplex *work, + doublereal *rwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2; + + /* Local variables */ + integer ibnd; + doublereal tola; + integer isub; + doublereal tolb, unfl, temp, smax; + integer ncallmycycle, i__, j; + extern logical lsame_(char *, char *); + doublereal anorm, bnorm; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical wantq, wantu, wantv; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + extern /* Subroutine */ int ztgsja_(char *, char *, char *, integer *, + integer *, integer *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *), + zggsvp_(char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, doublecomplex *, integer * + , integer *, doublereal *, doublecomplex *, doublecomplex *, + integer *); + doublereal ulp; + + +/* -- 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..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + --rwork; + --iwork; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*p < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -10; + } else if (*ldb < f2cmax(1,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGGSVD", &i__1); + return 0; + } + +/* Compute the Frobenius norm of matrices A and B */ + + anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]); + bnorm = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]); + +/* Get machine precision and set up threshold for determining */ +/* the effective numerical rank of the matrices A and B. */ + + ulp = dlamch_("Precision"); + unfl = dlamch_("Safe Minimum"); + tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp; + tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp; + + zggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, & + tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[ + q_offset], ldq, &iwork[1], &rwork[1], &work[1], &work[*n + 1], + info); + +/* Compute the GSVD of two upper "triangular" matrices */ + + ztgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], + ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[ + v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info); + +/* Sort the singular values and store the pivot indices in IWORK */ +/* Copy ALPHA to RWORK, then sort ALPHA in RWORK */ + + dcopy_(n, &alpha[1], &c__1, &rwork[1], &c__1); +/* Computing MIN */ + i__1 = *l, i__2 = *m - *k; + ibnd = f2cmin(i__1,i__2); + i__1 = ibnd; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for largest ALPHA(K+I) */ + + isub = i__; + smax = rwork[*k + i__]; + i__2 = ibnd; + for (j = i__ + 1; j <= i__2; ++j) { + temp = rwork[*k + j]; + if (temp > smax) { + isub = j; + smax = temp; + } +/* L10: */ + } + if (isub != i__) { + rwork[*k + isub] = rwork[*k + i__]; + rwork[*k + i__] = smax; + iwork[*k + i__] = *k + isub; + } else { + iwork[*k + i__] = *k + i__; + } +/* L20: */ + } + + return 0; + +/* End of ZGGSVD */ + +} /* zggsvd_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/zggsvp.c b/lapack-netlib/SRC/DEPRECATED/zggsvp.c new file mode 100644 index 000000000..361b1fa47 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/zggsvp.c @@ -0,0 +1,1015 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZGGSVP */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGGSVP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, */ +/* TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, */ +/* IWORK, RWORK, TAU, WORK, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */ +/* DOUBLE PRECISION TOLA, TOLB */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZGGSVP3. */ +/* > */ +/* > ZGGSVP computes unitary matrices U, V and Q such that */ +/* > */ +/* > N-K-L K L */ +/* > U**H*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* > L ( 0 0 A23 ) */ +/* > M-K-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* > M-K ( 0 0 A23 ) */ +/* > */ +/* > N-K-L K L */ +/* > V**H*B*Q = L ( 0 0 B13 ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* > otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */ +/* > numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. */ +/* > */ +/* > This decomposition is the preprocessing step for computing the */ +/* > Generalized Singular Value Decomposition (GSVD), see subroutine */ +/* > ZGGSVD. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': Unitary matrix U is computed; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': Unitary matrix V is computed; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Unitary matrix Q is computed; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A contains the triangular (or trapezoidal) matrix */ +/* > described in the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, B contains the triangular matrix described in */ +/* > the Purpose section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLA */ +/* > \verbatim */ +/* > TOLA is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLB */ +/* > \verbatim */ +/* > TOLB is DOUBLE PRECISION */ +/* > */ +/* > TOLA and TOLB are the thresholds to determine the effective */ +/* > numerical rank of matrix B and a subblock of A. Generally, */ +/* > they are set to */ +/* > TOLA = MAX(M,N)*norm(A)*MAZHEPS, */ +/* > TOLB = MAX(P,N)*norm(B)*MAZHEPS. */ +/* > The size of TOLA and TOLB may affect the size of backward */ +/* > errors of the decomposition. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > On exit, K and L specify the dimension of the subblocks */ +/* > described in Purpose section. */ +/* > K + L = effective numerical rank of (A**H,B**H)**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is COMPLEX*16 array, dimension (LDU,M) */ +/* > If JOBU = 'U', U contains the unitary matrix U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (LDV,P) */ +/* > If JOBV = 'V', V contains the unitary matrix V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX*16 array, dimension (LDQ,N) */ +/* > If JOBQ = 'Q', Q contains the unitary matrix Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (f2cmax(3*N,M,P)) */ +/* > \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 complex16OTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The subroutine uses LAPACK subroutine ZGEQPF for the QR factorization */ +/* > with column pivoting to detect the effective numerical rank of the */ +/* > a matrix. It may be replaced by a better rank determination strategy. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m, + integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex + *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k, + integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer + *ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal * + rwork, doublecomplex *tau, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + logical wantq, wantu, wantv; + extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), zgerq2_( + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *), zung2r_(integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *), zunm2r_(char *, char *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), zunmr2_(char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *), xerbla_( + char *, integer *), zgeqpf_(integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *), zlacpy_(char *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *); + logical forwrd; + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlapmt_(logical *, integer *, integer *, doublecomplex *, + integer *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --iwork; + --rwork; + --tau; + --work; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + forwrd = TRUE_; + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -8; + } else if (*ldb < f2cmax(1,*p)) { + *info = -10; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGGSVP", &i__1); + return 0; + } + +/* QR with column pivoting of B: B*P = V*( S11 S12 ) */ +/* ( 0 0 ) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + zgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1], + info); + +/* Update A := A*P */ + + zlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); + +/* Determine the effective rank of matrix B. */ + + *l = 0; + i__1 = f2cmin(*p,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * b_dim1; + if ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + i__ * + b_dim1]), abs(d__2)) > *tolb) { + ++(*l); + } +/* L20: */ + } + + if (wantv) { + +/* Copy the details of V, and form V. */ + + zlaset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv); + if (*p > 1) { + i__1 = *p - 1; + zlacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], + ldv); + } + i__1 = f2cmin(*p,*n); + zung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); + } + +/* Clean up B */ + + i__1 = *l - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L30: */ + } +/* L40: */ + } + if (*p > *l) { + i__1 = *p - *l; + zlaset_("Full", &i__1, n, &c_b1, &c_b1, &b[*l + 1 + b_dim1], ldb); + } + + if (wantq) { + +/* Set Q = I and Update Q := Q*P */ + + zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); + zlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); + } + + if (*p >= *l && *n != *l) { + +/* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */ + + zgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); + +/* Update A := A*Z**H */ + + zunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, & + tau[1], &a[a_offset], lda, &work[1], info); + if (wantq) { + +/* Update Q := Q*Z**H */ + + zunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset], + ldb, &tau[1], &q[q_offset], ldq, &work[1], info); + } + +/* Clean up B */ + + i__1 = *n - *l; + zlaset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb); + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L50: */ + } +/* L60: */ + } + + } + +/* Let N-L L */ +/* A = ( A11 A12 ) M, */ + +/* then the following does the complete QR decomposition of A11: */ + +/* A11 = U*( 0 T12 )*P1**H */ +/* ( 0 0 ) */ + + i__1 = *n - *l; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L70: */ + } + i__1 = *n - *l; + zgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[ + 1], info); + +/* Determine the effective rank of A11 */ + + *k = 0; +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + i__ * + a_dim1]), abs(d__2)) > *tola) { + ++(*k); + } +/* L80: */ + } + +/* Update A12 := U**H*A12, where A12 = A( 1:M, N-L+1:N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + zunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, & + tau[1], &a[(*n - *l + 1) * a_dim1 + 1], lda, &work[1], info); + + if (wantu) { + +/* Copy the details of U, and form U */ + + zlaset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu); + if (*m > 1) { + i__1 = *m - 1; + i__2 = *n - *l; + zlacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] + , ldu); + } +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = f2cmin(i__2,i__3); + zung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); + } + + if (wantq) { + +/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ + + i__1 = *n - *l; + zlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); + } + +/* Clean up A: set the strictly lower triangular part of */ +/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L90: */ + } +/* L100: */ + } + if (*m > *k) { + i__1 = *m - *k; + i__2 = *n - *l; + zlaset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a[*k + 1 + a_dim1], lda); + } + + if (*n - *l > *k) { + +/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ + + i__1 = *n - *l; + zgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); + + if (wantq) { + +/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**H */ + + i__1 = *n - *l; + zunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset], + lda, &tau[1], &q[q_offset], ldq, &work[1], info); + } + +/* Clean up A */ + + i__1 = *n - *l - *k; + zlaset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda); + i__1 = *n - *l; + for (j = *n - *l - *k + 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L110: */ + } +/* L120: */ + } + + } + + if (*m > *k) { + +/* QR factorization of A( K+1:M,N-L+1:N ) */ + + i__1 = *m - *k; + zgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & + work[1], info); + + if (wantu) { + +/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ + + i__1 = *m - *k; +/* Computing MIN */ + i__3 = *m - *k; + i__2 = f2cmin(i__3,*l); + zunm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n + - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + + 1], ldu, &work[1], info); + } + +/* Clean up */ + + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L130: */ + } +/* L140: */ + } + + } + + return 0; + +/* End of ZGGSVP */ + +} /* zggsvp_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/zlahrd.c b/lapack-netlib/SRC/DEPRECATED/zlahrd.c new file mode 100644 index 000000000..34721441d --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/zlahrd.c @@ -0,0 +1,737 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below th +e k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformati +on to the unreduced part of A. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAHRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */ + +/* INTEGER K, LDA, LDT, LDY, N, NB */ +/* COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), */ +/* $ Y( LDY, NB ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZLAHR2. */ +/* > */ +/* > ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) */ +/* > matrix A so that elements below the k-th subdiagonal are zero. The */ +/* > reduction is performed by a unitary similarity transformation */ +/* > Q**H * A * Q. The routine returns the matrices V and T which determine */ +/* > Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. */ +/* > \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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of columns to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 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 >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 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 COMPLEX*16 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 >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \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**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex 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**H) * (A - Y*V**H). */ +/* > */ +/* > The contents of A on exit are illustrated by the following example */ +/* > with n = 7, k = 3 and nb = 2: */ +/* > */ +/* > ( a h a a a ) */ +/* > ( a h a a a ) */ +/* > ( a h 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). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlahrd_(integer *n, integer *k, integer *nb, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t, + integer *ldt, doublecomplex *y, integer *ldy) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *), ztrmv_(char *, char *, + char *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *); + doublecomplex ei; + extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *, + doublecomplex *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + 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(1:n,i) */ + +/* Compute i-th column of A - Y * V**H */ + + i__2 = i__ - 1; + zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda); + i__2 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &a[*k + + i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], & + c__1); + i__2 = i__ - 1; + zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda); + +/* Apply I - V * T**H * V**H 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**H * b1 */ + + i__2 = i__ - 1; + zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + ztrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 + + a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1); + +/* w := w + V2**H *b2 */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, & + t[*nb * t_dim1 + 1], &c__1); + +/* w := T**H *w */ + + i__2 = i__ - 1; + ztrmv_("Upper", "Conjugate 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; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ + + i__ * a_dim1], &c__1); + +/* b1 := b1 - V1*w */ + + i__2 = i__ - 1; + ztrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1] + , lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ + * a_dim1], &c__1); + + i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1; + a[i__2].r = ei.r, a[i__2].i = ei.i; + } + +/* Generate the elementary reflector H(i) to annihilate */ +/* A(k+i+1:n,i) */ + + i__2 = *k + i__ + i__ * a_dim1; + ei.r = a[i__2].r, ei.i = a[i__2].i; + i__2 = *n - *k - i__ + 1; +/* Computing MIN */ + i__3 = *k + i__ + 1; + zlarfg_(&i__2, &ei, &a[f2cmin(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__]) + ; + i__2 = *k + i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Compute Y(1:n,i) */ + + i__2 = *n - *k - i__ + 1; + zgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ * + y_dim1 + 1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[ + i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &t[i__ * + t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1); + zscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1); + +/* Compute T(1:i,i) */ + + i__2 = i__ - 1; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[i__ * t_dim1 + 1], &c__1) + ; + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + +/* L10: */ + } + i__1 = *k + *nb + *nb * a_dim1; + a[i__1].r = ei.r, a[i__1].i = ei.i; + + return 0; + +/* End of ZLAHRD */ + +} /* zlahrd_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/zlatzm.c b/lapack-netlib/SRC/DEPRECATED/zlatzm.c new file mode 100644 index 000000000..77b5101d4 --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/zlatzm.c @@ -0,0 +1,631 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATZM */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLATZM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER INCV, LDC, M, N */ +/* COMPLEX*16 TAU */ +/* COMPLEX*16 C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZUNMRZ. */ +/* > */ +/* > ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix. */ +/* > */ +/* > Let P = I - tau*u*u**H, u = ( 1 ), */ +/* > ( v ) */ +/* > where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */ +/* > SIDE = 'R'. */ +/* > */ +/* > If SIDE equals 'L', let */ +/* > C = [ C1 ] 1 */ +/* > [ C2 ] m-1 */ +/* > n */ +/* > Then C is overwritten by P*C. */ +/* > */ +/* > If SIDE equals 'R', let */ +/* > C = [ C1, C2 ] m */ +/* > 1 n-1 */ +/* > Then C is overwritten by C*P. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form P * C */ +/* > = 'R': form C * P */ +/* > \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 COMPLEX*16 array, dimension */ +/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */ +/* > (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ +/* > The vector v in the representation of P. 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 COMPLEX*16 */ +/* > The value tau in the representation of P. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C1 */ +/* > \verbatim */ +/* > C1 is COMPLEX*16 array, dimension */ +/* > (LDC,N) if SIDE = 'L' */ +/* > (M,1) if SIDE = 'R' */ +/* > On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */ +/* > if SIDE = 'R'. */ +/* > */ +/* > On exit, the first row of P*C if SIDE = 'L', or the first */ +/* > column of C*P if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C2 */ +/* > \verbatim */ +/* > C2 is COMPLEX*16 array, dimension */ +/* > (LDC, N) if SIDE = 'L' */ +/* > (LDC, N-1) if SIDE = 'R' */ +/* > On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */ +/* > m x (n - 1) matrix C2 if SIDE = 'R'. */ +/* > */ +/* > On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */ +/* > if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the arrays C1 and C2. */ +/* > LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > (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 complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n, + doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex * + c1, doublecomplex *c2, integer *ldc, doublecomplex *work) +{ + /* System generated locals */ + integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1; + doublecomplex z__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zgeru_(integer *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *) + , zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *), zlacgv_(integer *, + doublecomplex *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c2_dim1 = *ldc; + c2_offset = 1 + c2_dim1 * 1; + c2 -= c2_offset; + c1_dim1 = *ldc; + c1_offset = 1 + c1_dim1 * 1; + c1 -= c1_offset; + --work; + + /* Function Body */ + if (f2cmin(*m,*n) == 0 || tau->r == 0. && tau->i == 0.) { + return 0; + } + + if (lsame_(side, "L")) { + +/* w := ( C1 + v**H * C2 )**H */ + + zcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1); + zlacgv_(n, &work[1], &c__1); + i__1 = *m - 1; + zgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, & + v[1], incv, &c_b1, &work[1], &c__1); + +/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w**H */ +/* [ C2 ] [ C2 ] [ v ] */ + + zlacgv_(n, &work[1], &c__1); + z__1.r = -tau->r, z__1.i = -tau->i; + zaxpy_(n, &z__1, &work[1], &c__1, &c1[c1_offset], ldc); + i__1 = *m - 1; + z__1.r = -tau->r, z__1.i = -tau->i; + zgeru_(&i__1, n, &z__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], + ldc); + + } else if (lsame_(side, "R")) { + +/* w := C1 + C2 * v */ + + zcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1); + i__1 = *n - 1; + zgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1], + incv, &c_b1, &work[1], &c__1); + +/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**H] */ + + z__1.r = -tau->r, z__1.i = -tau->i; + zaxpy_(m, &z__1, &work[1], &c__1, &c1[c1_offset], &c__1); + i__1 = *n - 1; + z__1.r = -tau->r, z__1.i = -tau->i; + zgerc_(m, &i__1, &z__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], + ldc); + } + + return 0; + +/* End of ZLATZM */ + +} /* zlatzm_ */ + diff --git a/lapack-netlib/SRC/DEPRECATED/ztzrqf.c b/lapack-netlib/SRC/DEPRECATED/ztzrqf.c new file mode 100644 index 000000000..5b08f854f --- /dev/null +++ b/lapack-netlib/SRC/DEPRECATED/ztzrqf.c @@ -0,0 +1,662 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(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))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZTZRQF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZTZRQF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine is deprecated and has been replaced by routine ZTZRZF. */ +/* > */ +/* > ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */ +/* > to upper triangular form by means of unitary transformations. */ +/* > */ +/* > The upper trapezoidal matrix A is factored as */ +/* > */ +/* > A = ( R 0 ) * Z, */ +/* > */ +/* > where Z is an N-by-N unitary matrix and R is an M-by-M upper */ +/* > triangular matrix. */ +/* > \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 >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the leading M-by-N upper trapezoidal part of the */ +/* > array A must contain the matrix to be factorized. */ +/* > On exit, the leading M-by-M upper triangular part of A */ +/* > contains the upper triangular matrix R, and elements M+1 to */ +/* > N of the first M rows of A, with the array TAU, represent the */ +/* > unitary matrix Z as a product of M elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (M) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \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 complex16OTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The factorization is obtained by Householder's method. The kth */ +/* > transformation matrix, Z( k ), whose conjugate transpose is used to */ +/* > introduce zeros into the (m - k + 1)th row of A, is given in the form */ +/* > */ +/* > Z( k ) = ( I 0 ), */ +/* > ( 0 T( k ) ) */ +/* > */ +/* > where */ +/* > */ +/* > T( k ) = I - tau*u( k )*u( k )**H, u( k ) = ( 1 ), */ +/* > ( 0 ) */ +/* > ( z( k ) ) */ +/* > */ +/* > tau is a scalar and z( k ) is an ( n - m ) element vector. */ +/* > tau and z( k ) are chosen to annihilate the elements of the kth row */ +/* > of X. */ +/* > */ +/* > The scalar tau is returned in the kth element of TAU and the vector */ +/* > u( k ) in the kth row of A, such that the elements of z( k ) are */ +/* > in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* > the upper triangular part of A. */ +/* > */ +/* > Z is given by */ +/* > */ +/* > Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int ztzrqf_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer i__, k; + doublecomplex alpha; + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer m1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), xerbla_( + char *, integer *), zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *, + doublecomplex *, integer *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZTZRQF", &i__1); + return 0; + } + +/* Perform the factorization. */ + + if (*m == 0) { + return 0; + } + if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + tau[i__2].r = 0., tau[i__2].i = 0.; +/* L10: */ + } + } else { +/* Computing MIN */ + i__1 = *m + 1; + m1 = f2cmin(i__1,*n); + for (k = *m; k >= 1; --k) { + +/* Use a Householder reflection to zero the kth row of A. */ +/* First set up the reflection. */ + + i__1 = k + k * a_dim1; + d_cnjg(&z__1, &a[k + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = *n - *m; + zlacgv_(&i__1, &a[k + m1 * a_dim1], lda); + i__1 = k + k * a_dim1; + alpha.r = a[i__1].r, alpha.i = a[i__1].i; + i__1 = *n - *m + 1; + zlarfg_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]); + i__1 = k + k * a_dim1; + a[i__1].r = alpha.r, a[i__1].i = alpha.i; + i__1 = k; + d_cnjg(&z__1, &tau[k]); + tau[i__1].r = z__1.r, tau[i__1].i = z__1.i; + + i__1 = k; + if ((tau[i__1].r != 0. || tau[i__1].i != 0.) && k > 1) { + +/* We now perform the operation A := A*P( k )**H. */ + +/* Use the first ( k - 1 ) elements of TAU to store a( k ), */ +/* where a( k ) consists of the first ( k - 1 ) elements of */ +/* the kth column of A. Also let B denote the first */ +/* ( k - 1 ) rows of the last ( n - m ) columns of A. */ + + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1); + +/* Form w = a( k ) + B*z( k ) in TAU. */ + + i__1 = k - 1; + i__2 = *n - *m; + zgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 + + 1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], & + c__1); + +/* Now form a( k ) := a( k ) - conjg(tau)*w */ +/* and B := B - conjg(tau)*w*z( k )**H. */ + + i__1 = k - 1; + d_cnjg(&z__2, &tau[k]); + z__1.r = -z__2.r, z__1.i = -z__2.i; + zaxpy_(&i__1, &z__1, &tau[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + i__1 = k - 1; + i__2 = *n - *m; + d_cnjg(&z__2, &tau[k]); + z__1.r = -z__2.r, z__1.i = -z__2.i; + zgerc_(&i__1, &i__2, &z__1, &tau[1], &c__1, &a[k + m1 * + a_dim1], lda, &a[m1 * a_dim1 + 1], lda); + } +/* L20: */ + } + } + + return 0; + +/* End of ZTZRQF */ + +} /* ztzrqf_ */ +