From f437339130a7e3878a94b2a2ea87edbdd05ba5cf Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 12:12:26 +0100 Subject: [PATCH] Implement truncated QR with pivoting (Reference-LAPACK PR 891) --- lapack-netlib/SRC/cgeqp3rk.c | 1071 +++++++++++++++++++++++++++++++ lapack-netlib/SRC/claqp2rk.c | 943 +++++++++++++++++++++++++++ lapack-netlib/SRC/claqp3rk.c | 1152 +++++++++++++++++++++++++++++++++ lapack-netlib/SRC/dgeqp3rk.c | 1059 +++++++++++++++++++++++++++++++ lapack-netlib/SRC/dlaqp2rk.c | 923 +++++++++++++++++++++++++++ lapack-netlib/SRC/dlaqp3rk.c | 1113 ++++++++++++++++++++++++++++++++ lapack-netlib/SRC/sgeqp3rk.c | 1055 +++++++++++++++++++++++++++++++ lapack-netlib/SRC/slaqp2rk.c | 918 +++++++++++++++++++++++++++ lapack-netlib/SRC/slaqp3rk.c | 1109 ++++++++++++++++++++++++++++++++ lapack-netlib/SRC/zgeqp3rk.c | 1074 +++++++++++++++++++++++++++++++ lapack-netlib/SRC/zlaqp2rk.c | 947 ++++++++++++++++++++++++++++ lapack-netlib/SRC/zlaqp3rk.c | 1157 ++++++++++++++++++++++++++++++++++ 12 files changed, 12521 insertions(+) create mode 100644 lapack-netlib/SRC/cgeqp3rk.c create mode 100644 lapack-netlib/SRC/claqp2rk.c create mode 100644 lapack-netlib/SRC/claqp3rk.c create mode 100644 lapack-netlib/SRC/dgeqp3rk.c create mode 100644 lapack-netlib/SRC/dlaqp2rk.c create mode 100644 lapack-netlib/SRC/dlaqp3rk.c create mode 100644 lapack-netlib/SRC/sgeqp3rk.c create mode 100644 lapack-netlib/SRC/slaqp2rk.c create mode 100644 lapack-netlib/SRC/slaqp3rk.c create mode 100644 lapack-netlib/SRC/zgeqp3rk.c create mode 100644 lapack-netlib/SRC/zlaqp2rk.c create mode 100644 lapack-netlib/SRC/zlaqp3rk.c diff --git a/lapack-netlib/SRC/cgeqp3rk.c b/lapack-netlib/SRC/cgeqp3rk.c new file mode 100644 index 000000000..54e7fb140 --- /dev/null +++ b/lapack-netlib/SRC/cgeqp3rk.c @@ -0,0 +1,1071 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + +/* Check if the matrix A contains +Inf or -Inf, set INFO parameter */ +/* to the column number, where the first +/-Inf is found plus N, */ +/* and continue the computation. */ + + *info = *n + kp1; + + } + +/* ================================================================== */ + +/* Quick return if possible for the case when the first */ +/* stopping criterion is satisfied, i.e. KMAX = 0. */ + + if (*kmax == 0) { + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.f; + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + } + +/* ================================================================== */ + + eps = slamch_("Epsilon"); + +/* Adjust ABSTOL */ + + if (*abstol >= 0.f) { + safmin = slamch_("Safe minimum"); +/* Computing MAX */ + r__1 = *abstol, r__2 = safmin * 2.f; + *abstol = f2cmax(r__1,r__2); + } + +/* Adjust RELTOL */ + + if (*reltol >= 0.f) { + *reltol = f2cmax(*reltol,eps); + } + +/* =================================================================== */ + +/* JMAX is the maximum index of the column to be factorized, */ +/* which is also limited by the first stopping criterion KMAX. */ + + jmax = f2cmin(*kmax,minmn); + +/* =================================================================== */ + +/* Quick return if possible for the case when the second or third */ +/* stopping criterion for the whole original matrix is satified, */ +/* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL */ +/* (which is ONE <= RELTOL). */ + + if (maxc2nrm <= *abstol || 1.f <= *reltol) { + + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.f; + + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + } + +/* ================================================================== */ +/* Factorize columns */ +/* ================================================================== */ + +/* Determine the block size. */ + + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < minmn) { + +/* Determine when to cross over from blocked to unblocked code. */ +/* (for N less than NX, unblocked code should be used). */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "CGEQP3RK", " ", m, n, &c_n1, &c_n1, ( + ftnlen)8, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + if (nx < minmn) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal block size that */ +/* is currently stored in NB. */ +/* Reduce NB and determine the minimum value of NB. */ + + nb = (*lwork - (*n << 1)) / (*n + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CGEQP3RK", " ", m, n, &c_n1, + &c_n1, (ftnlen)8, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + } + } + } + +/* ================================================================== */ + +/* DONE is the boolean flag to rerpresent the case when the */ +/* factorization completed in the block factorization routine, */ +/* before the end of the block. */ + + done = FALSE_; + +/* J is the column index. */ + + j = 1; + +/* (1) Use blocked code initially. */ + +/* JMAXB is the maximum column index of the block, when the */ +/* blocked code is used, is also limited by the first stopping */ +/* criterion KMAX. */ + +/* Computing MIN */ + i__1 = *kmax, i__2 = minmn - nx; + jmaxb = f2cmin(i__1,i__2); + + if (nb >= nbmin && nb < jmax && jmaxb > 0) { + +/* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: */ +/* J is the column index of a column block; */ +/* JB is the column block size to pass to block factorization */ +/* routine in a loop step; */ +/* JBF is the number of columns that were actually factorized */ +/* that was returned by the block factorization routine */ +/* in a loop step, JBF <= JB; */ +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + while(j <= jmaxb) { + +/* Computing MIN */ + i__1 = nb, i__2 = jmaxb - j + 1; + jb = f2cmin(i__1,i__2); + n_sub__ = *n - j + 1; + ioffset = j - 1; + +/* Factorize JB columns among the columns A(J:N). */ + + i__1 = *n + *nrhs - j + 1; + claqp3rk_(m, &n_sub__, nrhs, &ioffset, &jb, abstol, reltol, &kp1, + &maxc2nrm, &a[j * a_dim1 + 1], lda, &done, &jbf, + maxc2nrmk, relmaxc2nrmk, &jpiv[j], &tau[j], &rwork[j], & + rwork[*n + j], &work[1], &work[jb + 1], &i__1, &iwork[1], + &iinfo); + +/* Set INFO on the first occurence of Inf. */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } + + if (done) { + +/* Either the submatrix is zero before the end of the */ +/* column block, or ABSTOL or RELTOL criterion is */ +/* satisfied before the end of the column block, we can */ +/* return from the routine. Perform the following before */ +/* returning: */ +/* a) Set the number of factorized columns K, */ +/* K = IOFFSET + JBF from the last call of blocked */ +/* routine. */ +/* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned */ +/* by the block factorization routine; */ +/* 2) The remaining TAUs are set to ZERO by the */ +/* block factorization routine. */ + + *k = ioffset + jbf; + +/* Set INFO on the first occurrence of NaN, NaN takes */ +/* prcedence over Inf. */ + + if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + +/* Return from the routine. */ + + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + + return 0; + + } + + j += jbf; + + } + + } + +/* Use unblocked code to factor the last or only block. */ +/* J = JMAX+1 means we factorized the maximum possible number of */ +/* columns, that is in ELSE clause we need to compute */ +/* the MAXC2NORM and RELMAXC2NORM to return after we processed */ +/* the blocks. */ + + if (j <= jmax) { + +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + n_sub__ = *n - j + 1; + ioffset = j - 1; + + i__1 = jmax - j + 1; + claqp2rk_(m, &n_sub__, nrhs, &ioffset, &i__1, abstol, reltol, &kp1, & + maxc2nrm, &a[j * a_dim1 + 1], lda, &kf, maxc2nrmk, + relmaxc2nrmk, &jpiv[j], &tau[j], &rwork[j], &rwork[*n + j], & + work[1], &iinfo); + +/* ABSTOL or RELTOL criterion is satisfied when the number of */ +/* the factorized columns KF is smaller then the number */ +/* of columns JMAX-J+1 supplied to be factorized by the */ +/* unblocked routine, we can return from */ +/* the routine. Perform the following before returning: */ +/* a) Set the number of factorized columns K, */ +/* b) MAXC2NRMK and RELMAXC2NRMK are returned by the */ +/* unblocked factorization routine above. */ + + *k = j - 1 + kf; + +/* Set INFO on the first exception occurence. */ + +/* Set INFO on the first exception occurence of Inf or NaN, */ +/* (NaN takes precedence over Inf). */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } else if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + + } else { + +/* Compute the return values for blocked code. */ + +/* Set the number of factorized columns if the unblocked routine */ +/* was not called. */ + + *k = jmax; + +/* If there exits a residual matrix after the blocked code: */ +/* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the */ +/* residual matrix, otherwise set them to ZERO; */ +/* 2) Set TAU(K+1:MINMN) to ZERO. */ + + if (*k < minmn) { + i__1 = *n - *k; + jmaxc2nrm = *k + isamax_(&i__1, &rwork[*k + 1], &c__1); + *maxc2nrmk = rwork[jmaxc2nrm]; + if (*k == 0) { + *relmaxc2nrmk = 1.f; + } else { + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + } + + i__1 = minmn; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + + } else { + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + + } + +/* END IF( J.LE.JMAX ) THEN */ + + } + + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + + return 0; + +/* End of CGEQP3RK */ + +} /* cgeqp3rk_ */ + diff --git a/lapack-netlib/SRC/claqp2rk.c b/lapack-netlib/SRC/claqp2rk.c new file mode 100644 index 000000000..4184c5927 --- /dev/null +++ b/lapack-netlib/SRC/claqp2rk.c @@ -0,0 +1,943 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + *info = *n + kk - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL >= ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL >= ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + +/* Set K, the number of factorized columns. */ + + *k = kk - 1; + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. */ + + i__2 = minmnfact; + for (j = kk; j <= i__2; ++j) { + i__3 = j; + tau[i__3].r = 0.f, tau[i__3].i = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,KK:N): */ +/* 1) swap the KK-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) copy the KK-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than KK in the next loop step.) */ +/* 3) Save the pivot interchange with the indices relative to the */ +/* the original matrix A, not the block A(1:M,1:N). */ + + if (kp != kk) { + cswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1); + vn1[kp] = vn1[kk]; + vn2[kp] = vn2[kk]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[kk]; + jpiv[kk] = itemp; + } + +/* Generate elementary reflector H(KK) using the column A(I:M,KK), */ +/* if the column has more than one element, otherwise */ +/* the elementary reflector would be an identity matrix, */ +/* and TAU(KK) = CZERO. */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + clarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], & + c__1, &tau[kk]); + } else { + i__2 = kk; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + +/* Check if TAU(KK) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(KK) for Inf, */ +/* since CLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by CLARFG can contain Inf, which requires */ +/* TAU(KK) to contain NaN. Therefore, this case of generating Inf */ +/* by CLARFG is covered by checking TAU(KK) for NaN. */ + + i__2 = kk; + r__1 = tau[i__2].r; + if (sisnan_(&r__1)) { + i__2 = kk; + taunan = tau[i__2].r; + } else /* if(complicated condition) */ { + r__1 = r_imag(&tau[kk]); + if (sisnan_(&r__1)) { + taunan = r_imag(&tau[kk]); + } else { + taunan = 0.f; + } + } + + if (sisnan_(&taunan)) { + *k = kk - 1; + *info = kk; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = taunan; + *relmaxc2nrmk = taunan; + +/* Array TAU(KK:MINMNFACT) is not set and contains */ +/* undefined elements, except the first element TAU(KK) = NaN. */ + + return 0; + } + +/* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. */ +/* ( If M >= N, then at KK = N there is no residual matrix, */ +/* i.e. no columns of A to update, only columns of B. */ +/* If M < N, then at KK = M-IOFFSET, I = M and we have a */ +/* one-row residual matrix in A and the elementary */ +/* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update */ +/* is needed for the residual matrix in A and the */ +/* right-hand-side-matrix in B. */ +/* Therefore, we update only if */ +/* KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */ +/* condition is satisfied, not only KK < N+NRHS ) */ + + if (kk < minmnupdt) { + i__2 = i__ + kk * a_dim1; + aikk.r = a[i__2].r, aikk.i = a[i__2].i; + i__2 = i__ + kk * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + i__2 = *m - i__ + 1; + i__3 = *n + *nrhs - kk; + r_cnjg(&q__1, &tau[kk]); + clarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &q__1, + &a[i__ + (kk + 1) * a_dim1], lda, &work[1]); + i__2 = i__ + kk * a_dim1; + a[i__2].r = aikk.r, a[i__2].i = aikk.i; + } + + if (kk < minmnfact) { + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */ +/* when KK < f2cmin(M-IOFFSET, N). */ + + i__2 = *n; + for (j = kk + 1; j <= i__2; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + r__1 = c_abs(&a[i__ + j * a_dim1]) / vn1[j]; + temp = 1.f - r__1 * r__1; + temp = f2cmax(temp,0.f); +/* Computing 2nd power */ + r__1 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + +/* Compute the column 2-norm for the partial */ +/* column A(I+1:M,J) by explicitly computing it, */ +/* and store it in both partial 2-norm vector VN1 */ +/* and exact column 2-norm vector VN2. */ + + i__3 = *m - i__; + vn1[j] = scnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + + } else { + +/* Update the column 2-norm for the partial */ +/* column A(I+1:M,J) by removing one */ +/* element A(I,J) and store it in partial */ +/* 2-norm vector VN1. */ + + vn1[j] *= sqrt(temp); + + } + } + } + + } + +/* End factorization loop */ + + } + +/* If we reached this point, all colunms have been factorized, */ +/* i.e. no condition was triggered to exit the routine. */ +/* Set the number of factorized columns. */ + + *k = *kmax; + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */ +/* we return. */ + + if (*k < minmnfact) { + + i__1 = *n - *k; + jmaxc2nrm = *k + isamax_(&i__1, &vn1[*k + 1], &c__1); + *maxc2nrmk = vn1[jmaxc2nrm]; + + if (*k == 0) { + *relmaxc2nrmk = 1.f; + } else { + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + } + + } else { + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + } + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, set TAUs corresponding to the columns that were */ +/* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. */ + + i__1 = minmnfact; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + + return 0; + +/* End of CLAQP2RK */ + +} /* claqp2rk_ */ + diff --git a/lapack-netlib/SRC/claqp3rk.c b/lapack-netlib/SRC/claqp3rk.c new file mode 100644 index 000000000..ca305fab7 --- /dev/null +++ b/lapack-netlib/SRC/claqp3rk.c @@ -0,0 +1,1152 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, + kb, &q__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* Quick return, if the submatrix A(I:M,K:N) is */ +/* a zero matrix. We need to check it only if the column index */ +/* (same as row index) is larger than 1, since the condition */ +/* for the whole original matrix A_orig is checked in the main */ +/* routine. */ + + if (*maxc2nrmk == 0.f) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *relmaxc2nrmk = 0.f; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix is zero and we stop the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, + kb, &q__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* Check if the submatrix A(I:M,K:N) contains Inf, */ +/* set INFO parameter to the column number, where */ +/* the first Inf is found plus N, and continue */ +/* the computation. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + if (*info == 0 && *maxc2nrmk > myhugeval) { + *info = *n + k - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third tolerance stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL.GE.ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig; */ + + *kb = k - 1; + if__ = i__ - 1; + +/* Apply the block reflector to the residual of the */ +/* matrix A and the residual of the right hand sides B, if */ +/* the residual matrix and and/or the residual of the right */ +/* hand sides exist, i.e. if the submatrix */ +/* A(I+1:M,KB+1:N+NRHS) exists. This occurs when */ +/* KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, & + i__2, kb, &q__1, &a[if__ + 1 + a_dim1], lda, &f[* + kb + 1 + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*kb + + 1) * a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,K:N): */ +/* 1) swap the K-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) */ +/* 3) copy the K-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. (Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than K in the next loop step.) */ +/* 4) Save the pivot interchange with the indices relative to the */ +/* the original matrix A_orig, not the block A(1:M,1:N). */ + + if (kp != k) { + cswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + cswap_(&i__1, &f[kp + f_dim1], ldf, &f[k + f_dim1], ldf); + vn1[kp] = vn1[k]; + vn2[kp] = vn2[k]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[k]; + jpiv[k] = itemp; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H. */ + + if (k > 1) { + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + r_cnjg(&q__1, &f[k + j * f_dim1]); + f[i__2].r = q__1.r, f[i__2].i = q__1.i; + } + i__1 = *m - i__ + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[i__ + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b2, &a[i__ + k * a_dim1], &c__1); + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + r_cnjg(&q__1, &f[k + j * f_dim1]); + f[i__2].r = q__1.r, f[i__2].i = q__1.i; + } + } + +/* Generate elementary reflector H(k) using the column A(I:M,K). */ + + if (i__ < *m) { + i__1 = *m - i__ + 1; + clarfg_(&i__1, &a[i__ + k * a_dim1], &a[i__ + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + i__1 = k; + tau[i__1].r = 0.f, tau[i__1].i = 0.f; + } + +/* Check if TAU(K) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(K) for Inf, */ +/* since CLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by CLARFG can contain Inf, which requires */ +/* TAU(K) to contain NaN. Therefore, this case of generating Inf */ +/* by CLARFG is covered by checking TAU(K) for NaN. */ + + i__1 = k; + r__1 = tau[i__1].r; + if (sisnan_(&r__1)) { + i__1 = k; + taunan = tau[i__1].r; + } else /* if(complicated condition) */ { + r__1 = r_imag(&tau[k]); + if (sisnan_(&r__1)) { + taunan = r_imag(&tau[k]); + } else { + taunan = 0.f; + } + } + + if (sisnan_(&taunan)) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *info = k; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = taunan; + *relmaxc2nrmk = taunan; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix contains NaN and we stop */ +/* the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, kb, + &q__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * a_dim1], + lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* =============================================================== */ + + i__1 = i__ + k * a_dim1; + aik.r = a[i__1].r, aik.i = a[i__1].i; + i__1 = i__ + k * a_dim1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + +/* =============================================================== */ + +/* Compute the current K-th column of F: */ +/* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K). */ + + if (k < *n + *nrhs) { + i__1 = *m - i__ + 1; + i__2 = *n + *nrhs - k; + cgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[i__ + (k + + 1) * a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b1, & + f[k + 1 + k * f_dim1], &c__1); + } + +/* 2) Zero out elements above and on the diagonal of the */ +/* column K in matrix F, i.e elements F(1:K,K). */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + i__2 = j + k * f_dim1; + f[i__2].r = 0.f, f[i__2].i = 0.f; + } + +/* 3) Incremental updating of the K-th column of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H */ +/* * A(I:M,K). */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + i__3 = k; + q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; + cgemv_("Conjugate Transpose", &i__1, &i__2, &q__1, &a[i__ + + a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b1, &auxv[1] + , &c__1); + + i__1 = *n + *nrhs; + i__2 = k - 1; + cgemv_("No transpose", &i__1, &i__2, &c_b2, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1); + } + +/* =============================================================== */ + +/* Update the current I-th row of A: */ +/* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) */ +/* - A(I,1:K)*F(K+1:N+NRHS,1:K)**H. */ + + if (k < *n + *nrhs) { + i__1 = *n + *nrhs - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, & + q__1, &a[i__ + a_dim1], lda, &f[k + 1 + f_dim1], ldf, & + c_b2, &a[i__ + (k + 1) * a_dim1], lda); + } + + i__1 = i__ + k * a_dim1; + a[i__1].r = aik.r, a[i__1].i = aik.i; + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. */ +/* when K < MINMNFACT = f2cmin( M-IOFFSET, N ). */ + + if (k < minmnfact) { + + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = c_abs(&a[i__ + j * a_dim1]) / vn1[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 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + +/* At J-index, we have a difficult column for the */ +/* update of the 2-norm. Save the index of the previous */ +/* difficult column in IWORK(J-1). */ +/* NOTE: ILSTCC > 1, threfore we can use IWORK only */ +/* with N-1 elements, where the elements are */ +/* shifted by 1 to the left. */ + + iwork[j - 1] = lsticc; + +/* Set the index of the last difficult column LSTICC. */ + + lsticc = j; + + } else { + vn1[j] *= sqrt(temp); + } + } + } + + } + +/* End of while loop. */ + + } + +/* Now, afler the loop: */ +/* Set KB, the number of factorized columns in the block; */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig, IF = IOFFSET + KB. */ + + *kb = k; + if__ = i__; + +/* Apply the block reflector to the residual of the matrix A */ +/* and the residual of the right hand sides B, if the residual */ +/* matrix and and/or the residual of the right hand sides */ +/* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. */ +/* This occurs when KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &q__1, + &a[if__ + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, + &a[if__ + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recompute the 2-norm of the difficult columns. */ +/* Loop over the index of the difficult columns from the largest */ +/* to the smallest index. */ + + while(lsticc > 0) { + +/* LSTICC is the index of the last difficult column is greater */ +/* than 1. */ +/* ITEMP is the index of the previous difficult column. */ + + itemp = iwork[lsticc - 1]; + +/* Compute the 2-norm explicilty for the last difficult column and */ +/* save it in the partial and exact 2-norm vectors VN1 and VN2. */ + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* SCNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(SLAMCH('S')) */ + + i__1 = *m - if__; + vn1[lsticc] = scnrm2_(&i__1, &a[if__ + 1 + lsticc * a_dim1], &c__1); + vn2[lsticc] = vn1[lsticc]; + +/* Downdate the index of the last difficult column to */ +/* the index of the previous difficult column. */ + + lsticc = itemp; + + } + + return 0; + +/* End of CLAQP3RK */ + +} /* claqp3rk_ */ + diff --git a/lapack-netlib/SRC/dgeqp3rk.c b/lapack-netlib/SRC/dgeqp3rk.c new file mode 100644 index 000000000..17a78dd5a --- /dev/null +++ b/lapack-netlib/SRC/dgeqp3rk.c @@ -0,0 +1,1059 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + +/* Check if the matrix A contains +Inf or -Inf, set INFO parameter */ +/* to the column number, where the first +/-Inf is found plus N, */ +/* and continue the computation. */ + + *info = *n + kp1; + + } + +/* ================================================================== */ + +/* Quick return if possible for the case when the first */ +/* stopping criterion is satisfied, i.e. KMAX = 0. */ + + if (*kmax == 0) { + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.; + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + tau[j] = 0.; + } + work[1] = (doublereal) lwkopt; + return 0; + } + +/* ================================================================== */ + + eps = dlamch_("Epsilon"); + +/* Adjust ABSTOL */ + + if (*abstol >= 0.) { + safmin = dlamch_("Safe minimum"); +/* Computing MAX */ + d__1 = *abstol, d__2 = safmin * 2.; + *abstol = f2cmax(d__1,d__2); + } + +/* Adjust RELTOL */ + + if (*reltol >= 0.) { + *reltol = f2cmax(*reltol,eps); + } + +/* =================================================================== */ + +/* JMAX is the maximum index of the column to be factorized, */ +/* which is also limited by the first stopping criterion KMAX. */ + + jmax = f2cmin(*kmax,minmn); + +/* =================================================================== */ + +/* Quick return if possible for the case when the second or third */ +/* stopping criterion for the whole original matrix is satified, */ +/* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL */ +/* (which is ONE <= RELTOL). */ + + if (maxc2nrm <= *abstol || 1. <= *reltol) { + + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.; + + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + tau[j] = 0.; + } + + work[1] = (doublereal) lwkopt; + return 0; + } + +/* ================================================================== */ +/* Factorize columns */ +/* ================================================================== */ + +/* Determine the block size. */ + + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < minmn) { + +/* Determine when to cross over from blocked to unblocked code. */ +/* (for N less than NX, unblocked code should be used). */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQP3RK", " ", m, n, &c_n1, &c_n1, ( + ftnlen)8, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + if (nx < minmn) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal block size that */ +/* is currently stored in NB. */ +/* Reduce NB and determine the minimum value of NB. */ + + nb = (*lwork - (*n << 1)) / (*n + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQP3RK", " ", m, n, &c_n1, + &c_n1, (ftnlen)8, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + } + } + } + +/* ================================================================== */ + +/* DONE is the boolean flag to rerpresent the case when the */ +/* factorization completed in the block factorization routine, */ +/* before the end of the block. */ + + done = FALSE_; + +/* J is the column index. */ + + j = 1; + +/* (1) Use blocked code initially. */ + +/* JMAXB is the maximum column index of the block, when the */ +/* blocked code is used, is also limited by the first stopping */ +/* criterion KMAX. */ + +/* Computing MIN */ + i__1 = *kmax, i__2 = minmn - nx; + jmaxb = f2cmin(i__1,i__2); + + if (nb >= nbmin && nb < jmax && jmaxb > 0) { + +/* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: */ +/* J is the column index of a column block; */ +/* JB is the column block size to pass to block factorization */ +/* routine in a loop step; */ +/* JBF is the number of columns that were actually factorized */ +/* that was returned by the block factorization routine */ +/* in a loop step, JBF <= JB; */ +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + while(j <= jmaxb) { + +/* Computing MIN */ + i__1 = nb, i__2 = jmaxb - j + 1; + jb = f2cmin(i__1,i__2); + n_sub__ = *n - j + 1; + ioffset = j - 1; + +/* Factorize JB columns among the columns A(J:N). */ + + i__1 = *n + *nrhs - j + 1; + dlaqp3rk_(m, &n_sub__, nrhs, &ioffset, &jb, abstol, reltol, &kp1, + &maxc2nrm, &a[j * a_dim1 + 1], lda, &done, &jbf, + maxc2nrmk, relmaxc2nrmk, &jpiv[j], &tau[j], &work[j], & + work[*n + j], &work[(*n << 1) + 1], &work[(*n << 1) + jb + + 1], &i__1, &iwork[1], &iinfo); + +/* Set INFO on the first occurence of Inf. */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } + + if (done) { + +/* Either the submatrix is zero before the end of the */ +/* column block, or ABSTOL or RELTOL criterion is */ +/* satisfied before the end of the column block, we can */ +/* return from the routine. Perform the following before */ +/* returning: */ +/* a) Set the number of factorized columns K, */ +/* K = IOFFSET + JBF from the last call of blocked */ +/* routine. */ +/* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned */ +/* by the block factorization routine; */ +/* 2) The remaining TAUs are set to ZERO by the */ +/* block factorization routine. */ + + *k = ioffset + jbf; + +/* Set INFO on the first occurrence of NaN, NaN takes */ +/* prcedence over Inf. */ + + if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + +/* Return from the routine. */ + + work[1] = (doublereal) lwkopt; + + return 0; + + } + + j += jbf; + + } + + } + +/* Use unblocked code to factor the last or only block. */ +/* J = JMAX+1 means we factorized the maximum possible number of */ +/* columns, that is in ELSE clause we need to compute */ +/* the MAXC2NORM and RELMAXC2NORM to return after we processed */ +/* the blocks. */ + + if (j <= jmax) { + +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + n_sub__ = *n - j + 1; + ioffset = j - 1; + + i__1 = jmax - j + 1; + dlaqp2rk_(m, &n_sub__, nrhs, &ioffset, &i__1, abstol, reltol, &kp1, & + maxc2nrm, &a[j * a_dim1 + 1], lda, &kf, maxc2nrmk, + relmaxc2nrmk, &jpiv[j], &tau[j], &work[j], &work[*n + j], & + work[(*n << 1) + 1], &iinfo); + +/* ABSTOL or RELTOL criterion is satisfied when the number of */ +/* the factorized columns KF is smaller then the number */ +/* of columns JMAX-J+1 supplied to be factorized by the */ +/* unblocked routine, we can return from */ +/* the routine. Perform the following before returning: */ +/* a) Set the number of factorized columns K, */ +/* b) MAXC2NRMK and RELMAXC2NRMK are returned by the */ +/* unblocked factorization routine above. */ + + *k = j - 1 + kf; + +/* Set INFO on the first exception occurence. */ + +/* Set INFO on the first exception occurence of Inf or NaN, */ +/* (NaN takes precedence over Inf). */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } else if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + + } else { + +/* Compute the return values for blocked code. */ + +/* Set the number of factorized columns if the unblocked routine */ +/* was not called. */ + + *k = jmax; + +/* If there exits a residual matrix after the blocked code: */ +/* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the */ +/* residual matrix, otherwise set them to ZERO; */ +/* 2) Set TAU(K+1:MINMN) to ZERO. */ + + if (*k < minmn) { + i__1 = *n - *k; + jmaxc2nrm = *k + idamax_(&i__1, &work[*k + 1], &c__1); + *maxc2nrmk = work[jmaxc2nrm]; + if (*k == 0) { + *relmaxc2nrmk = 1.; + } else { + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + } + + i__1 = minmn; + for (j = *k + 1; j <= i__1; ++j) { + tau[j] = 0.; + } + + } + +/* END IF( J.LE.JMAX ) THEN */ + + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DGEQP3RK */ + +} /* dgeqp3rk_ */ + diff --git a/lapack-netlib/SRC/dlaqp2rk.c b/lapack-netlib/SRC/dlaqp2rk.c new file mode 100644 index 000000000..de216ad97 --- /dev/null +++ b/lapack-netlib/SRC/dlaqp2rk.c @@ -0,0 +1,923 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + *info = *n + kk - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL >= ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL >= ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + +/* Set K, the number of factorized columns. */ + + *k = kk - 1; + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. */ + + i__2 = minmnfact; + for (j = kk; j <= i__2; ++j) { + tau[j] = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,KK:N): */ +/* 1) swap the KK-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) copy the KK-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than KK in the next loop step.) */ +/* 3) Save the pivot interchange with the indices relative to the */ +/* the original matrix A, not the block A(1:M,1:N). */ + + if (kp != kk) { + dswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1); + vn1[kp] = vn1[kk]; + vn2[kp] = vn2[kk]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[kk]; + jpiv[kk] = itemp; + } + +/* Generate elementary reflector H(KK) using the column A(I:M,KK), */ +/* if the column has more than one element, otherwise */ +/* the elementary reflector would be an identity matrix, */ +/* and TAU(KK) = ZERO. */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + dlarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], & + c__1, &tau[kk]); + } else { + tau[kk] = 0.; + } + +/* Check if TAU(KK) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(KK) for Inf, */ +/* since DLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by DLARFG can contain Inf, which requires */ +/* TAU(KK) to contain NaN. Therefore, this case of generating Inf */ +/* by DLARFG is covered by checking TAU(KK) for NaN. */ + + if (disnan_(&tau[kk])) { + *k = kk - 1; + *info = kk; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = tau[kk]; + *relmaxc2nrmk = tau[kk]; + +/* Array TAU(KK:MINMNFACT) is not set and contains */ +/* undefined elements, except the first element TAU(KK) = NaN. */ + + return 0; + } + +/* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. */ +/* ( If M >= N, then at KK = N there is no residual matrix, */ +/* i.e. no columns of A to update, only columns of B. */ +/* If M < N, then at KK = M-IOFFSET, I = M and we have a */ +/* one-row residual matrix in A and the elementary */ +/* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update */ +/* is needed for the residual matrix in A and the */ +/* right-hand-side-matrix in B. */ +/* Therefore, we update only if */ +/* KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */ +/* condition is satisfied, not only KK < N+NRHS ) */ + + if (kk < minmnupdt) { + aikk = a[i__ + kk * a_dim1]; + a[i__ + kk * a_dim1] = 1.; + i__2 = *m - i__ + 1; + i__3 = *n + *nrhs - kk; + dlarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &tau[ + kk], &a[i__ + (kk + 1) * a_dim1], lda, &work[1]); + a[i__ + kk * a_dim1] = aikk; + } + + if (kk < minmnfact) { + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */ +/* when KK < f2cmin(M-IOFFSET, N). */ + + i__2 = *n; + for (j = kk + 1; j <= i__2; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / vn1[j]; + temp = 1. - d__2 * d__2; + temp = f2cmax(temp,0.); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + +/* Compute the column 2-norm for the partial */ +/* column A(I+1:M,J) by explicitly computing it, */ +/* and store it in both partial 2-norm vector VN1 */ +/* and exact column 2-norm vector VN2. */ + + i__3 = *m - i__; + vn1[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + + } else { + +/* Update the column 2-norm for the partial */ +/* column A(I+1:M,J) by removing one */ +/* element A(I,J) and store it in partial */ +/* 2-norm vector VN1. */ + + vn1[j] *= sqrt(temp); + + } + } + } + + } + +/* End factorization loop */ + + } + +/* If we reached this point, all colunms have been factorized, */ +/* i.e. no condition was triggered to exit the routine. */ +/* Set the number of factorized columns. */ + + *k = *kmax; + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */ +/* we return. */ + + if (*k < minmnfact) { + + i__1 = *n - *k; + jmaxc2nrm = *k + idamax_(&i__1, &vn1[*k + 1], &c__1); + *maxc2nrmk = vn1[jmaxc2nrm]; + + if (*k == 0) { + *relmaxc2nrmk = 1.; + } else { + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + } + + } else { + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + } + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, set TAUs corresponding to the columns that were */ +/* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. */ + + i__1 = minmnfact; + for (j = *k + 1; j <= i__1; ++j) { + tau[j] = 0.; + } + + return 0; + +/* End of DLAQP2RK */ + +} /* dlaqp2rk_ */ + diff --git a/lapack-netlib/SRC/dlaqp3rk.c b/lapack-netlib/SRC/dlaqp3rk.c new file mode 100644 index 000000000..e8c61c257 --- /dev/null +++ b/lapack-netlib/SRC/dlaqp3rk.c @@ -0,0 +1,1113 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + dgemm_("No transpose", "Transpose", &i__1, nrhs, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* Quick return, if the submatrix A(I:M,K:N) is */ +/* a zero matrix. We need to check it only if the column index */ +/* (same as row index) is larger than 1, since the condition */ +/* for the whole original matrix A_orig is checked in the main */ +/* routine. */ + + if (*maxc2nrmk == 0.) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *relmaxc2nrmk = 0.; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix is zero and we stop the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + dgemm_("No transpose", "Transpose", &i__1, nrhs, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + tau[j] = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* Check if the submatrix A(I:M,K:N) contains Inf, */ +/* set INFO parameter to the column number, where */ +/* the first Inf is found plus N, and continue */ +/* the computation. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + if (*info == 0 && *maxc2nrmk > myhugeval) { + *info = *n + k - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third tolerance stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL.GE.ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig; */ + + *kb = k - 1; + if__ = i__ - 1; + +/* Apply the block reflector to the residual of the */ +/* matrix A and the residual of the right hand sides B, if */ +/* the residual matrix and and/or the residual of the right */ +/* hand sides exist, i.e. if the submatrix */ +/* A(I+1:M,KB+1:N+NRHS) exists. This occurs when */ +/* KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + dgemm_("No transpose", "Transpose", &i__1, &i__2, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*kb + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*kb + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + tau[j] = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,K:N): */ +/* 1) swap the K-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) */ +/* 3) copy the K-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. (Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than K in the next loop step.) */ +/* 4) Save the pivot interchange with the indices relative to the */ +/* the original matrix A_orig, not the block A(1:M,1:N). */ + + if (kp != k) { + dswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + dswap_(&i__1, &f[kp + f_dim1], ldf, &f[k + f_dim1], ldf); + vn1[kp] = vn1[k]; + vn2[kp] = vn2[k]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[k]; + jpiv[k] = itemp; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b7, &a[i__ + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b8, &a[i__ + k * a_dim1], &c__1); + } + +/* Generate elementary reflector H(k) using the column A(I:M,K). */ + + if (i__ < *m) { + i__1 = *m - i__ + 1; + dlarfg_(&i__1, &a[i__ + k * a_dim1], &a[i__ + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + tau[k] = 0.; + } + +/* Check if TAU(K) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(K) for Inf, */ +/* since DLARFG cannot produce TAU(K) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by DLARFG can contain Inf, which requires */ +/* TAU(K) to contain NaN. Therefore, this case of generating Inf */ +/* by DLARFG is covered by checking TAU(K) for NaN. */ + + if (disnan_(&tau[k])) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *info = k; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = tau[k]; + *relmaxc2nrmk = tau[k]; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix contains NaN and we stop */ +/* the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + dgemm_("No transpose", "Transpose", &i__1, nrhs, kb, &c_b7, & + a[if__ + 1 + a_dim1], lda, &f[*n + 1 + f_dim1], ldf, & + c_b8, &a[if__ + 1 + (*n + 1) * a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* =============================================================== */ + + aik = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = 1.; + +/* =============================================================== */ + +/* Compute the current K-th column of F: */ +/* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). */ + + if (k < *n + *nrhs) { + i__1 = *m - i__ + 1; + i__2 = *n + *nrhs - k; + dgemv_("Transpose", &i__1, &i__2, &tau[k], &a[i__ + (k + 1) * + a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b30, &f[k + + 1 + k * f_dim1], &c__1); + } + +/* 2) Zero out elements above and on the diagonal of the */ +/* column K in matrix F, i.e elements F(1:K,K). */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + f[j + k * f_dim1] = 0.; + } + +/* 3) Incremental updating of the K-th column of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T */ +/* * A(I:M,K). */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + d__1 = -tau[k]; + dgemv_("Transpose", &i__1, &i__2, &d__1, &a[i__ + a_dim1], lda, & + a[i__ + k * a_dim1], &c__1, &c_b30, &auxv[1], &c__1); + + i__1 = *n + *nrhs; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b8, &f[k * f_dim1 + 1], &c__1); + } + +/* =============================================================== */ + +/* Update the current I-th row of A: */ +/* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) */ +/* - A(I,1:K)*F(K+1:N+NRHS,1:K)**T. */ + + if (k < *n + *nrhs) { + i__1 = *n + *nrhs - k; + dgemv_("No transpose", &i__1, &k, &c_b7, &f[k + 1 + f_dim1], ldf, + &a[i__ + a_dim1], lda, &c_b8, &a[i__ + (k + 1) * a_dim1], + lda); + } + + a[i__ + k * a_dim1] = aik; + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. */ +/* when K < MINMNFACT = f2cmin( M-IOFFSET, N ). */ + + if (k < minmnfact) { + + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / vn1[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = f2cmax(d__1,d__2); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + +/* At J-index, we have a difficult column for the */ +/* update of the 2-norm. Save the index of the previous */ +/* difficult column in IWORK(J-1). */ +/* NOTE: ILSTCC > 1, threfore we can use IWORK only */ +/* with N-1 elements, where the elements are */ +/* shifted by 1 to the left. */ + + iwork[j - 1] = lsticc; + +/* Set the index of the last difficult column LSTICC. */ + + lsticc = j; + + } else { + vn1[j] *= sqrt(temp); + } + } + } + + } + +/* End of while loop. */ + + } + +/* Now, afler the loop: */ +/* Set KB, the number of factorized columns in the block; */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig, IF = IOFFSET + KB. */ + + *kb = k; + if__ = i__; + +/* Apply the block reflector to the residual of the matrix A */ +/* and the residual of the right hand sides B, if the residual */ +/* matrix and and/or the residual of the right hand sides */ +/* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. */ +/* This occurs when KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + dgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b7, &a[if__ + + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b8, &a[if__ + + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recompute the 2-norm of the difficult columns. */ +/* Loop over the index of the difficult columns from the largest */ +/* to the smallest index. */ + + while(lsticc > 0) { + +/* LSTICC is the index of the last difficult column is greater */ +/* than 1. */ +/* ITEMP is the index of the previous difficult column. */ + + itemp = iwork[lsticc - 1]; + +/* Compute the 2-norm explicilty for the last difficult column and */ +/* save it in the partial and exact 2-norm vectors VN1 and VN2. */ + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* DNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(DLAMCH('S')) */ + + i__1 = *m - if__; + vn1[lsticc] = dnrm2_(&i__1, &a[if__ + 1 + lsticc * a_dim1], &c__1); + vn2[lsticc] = vn1[lsticc]; + +/* Downdate the index of the last difficult column to */ +/* the index of the previous difficult column. */ + + lsticc = itemp; + + } + + return 0; + +/* End of DLAQP3RK */ + +} /* dlaqp3rk_ */ + diff --git a/lapack-netlib/SRC/sgeqp3rk.c b/lapack-netlib/SRC/sgeqp3rk.c new file mode 100644 index 000000000..fe52901bf --- /dev/null +++ b/lapack-netlib/SRC/sgeqp3rk.c @@ -0,0 +1,1055 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + +/* Check if the matrix A contains +Inf or -Inf, set INFO parameter */ +/* to the column number, where the first +/-Inf is found plus N, */ +/* and continue the computation. */ + + *info = *n + kp1; + + } + +/* ================================================================== */ + +/* Quick return if possible for the case when the first */ +/* stopping criterion is satisfied, i.e. KMAX = 0. */ + + if (*kmax == 0) { + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.f; + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + tau[j] = 0.f; + } + work[1] = (real) lwkopt; + return 0; + } + +/* ================================================================== */ + + eps = slamch_("Epsilon"); + +/* Adjust ABSTOL */ + + if (*abstol >= 0.f) { + safmin = slamch_("Safe minimum"); +/* Computing MAX */ + r__1 = *abstol, r__2 = safmin * 2.f; + *abstol = f2cmax(r__1,r__2); + } + +/* Adjust RELTOL */ + + if (*reltol >= 0.f) { + *reltol = f2cmax(*reltol,eps); + } + +/* =================================================================== */ + +/* JMAX is the maximum index of the column to be factorized, */ +/* which is also limited by the first stopping criterion KMAX. */ + + jmax = f2cmin(*kmax,minmn); + +/* =================================================================== */ + +/* Quick return if possible for the case when the second or third */ +/* stopping criterion for the whole original matrix is satified, */ +/* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL */ +/* (which is ONE <= RELTOL). */ + + if (maxc2nrm <= *abstol || 1.f <= *reltol) { + + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.f; + + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + tau[j] = 0.f; + } + + work[1] = (real) lwkopt; + return 0; + } + +/* ================================================================== */ +/* Factorize columns */ +/* ================================================================== */ + +/* Determine the block size. */ + + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < minmn) { + +/* Determine when to cross over from blocked to unblocked code. */ +/* (for N less than NX, unblocked code should be used). */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "SGEQP3RK", " ", m, n, &c_n1, &c_n1, ( + ftnlen)8, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + if (nx < minmn) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal block size that */ +/* is currently stored in NB. */ +/* Reduce NB and determine the minimum value of NB. */ + + nb = (*lwork - (*n << 1)) / (*n + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "SGEQP3RK", " ", m, n, &c_n1, + &c_n1, (ftnlen)8, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + } + } + } + +/* ================================================================== */ + +/* DONE is the boolean flag to rerpresent the case when the */ +/* factorization completed in the block factorization routine, */ +/* before the end of the block. */ + + done = FALSE_; + +/* J is the column index. */ + + j = 1; + +/* (1) Use blocked code initially. */ + +/* JMAXB is the maximum column index of the block, when the */ +/* blocked code is used, is also limited by the first stopping */ +/* criterion KMAX. */ + +/* Computing MIN */ + i__1 = *kmax, i__2 = minmn - nx; + jmaxb = f2cmin(i__1,i__2); + + if (nb >= nbmin && nb < jmax && jmaxb > 0) { + +/* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: */ +/* J is the column index of a column block; */ +/* JB is the column block size to pass to block factorization */ +/* routine in a loop step; */ +/* JBF is the number of columns that were actually factorized */ +/* that was returned by the block factorization routine */ +/* in a loop step, JBF <= JB; */ +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + while(j <= jmaxb) { + +/* Computing MIN */ + i__1 = nb, i__2 = jmaxb - j + 1; + jb = f2cmin(i__1,i__2); + n_sub__ = *n - j + 1; + ioffset = j - 1; + +/* Factorize JB columns among the columns A(J:N). */ + + i__1 = *n + *nrhs - j + 1; + slaqp3rk_(m, &n_sub__, nrhs, &ioffset, &jb, abstol, reltol, &kp1, + &maxc2nrm, &a[j * a_dim1 + 1], lda, &done, &jbf, + maxc2nrmk, relmaxc2nrmk, &jpiv[j], &tau[j], &work[j], & + work[*n + j], &work[(*n << 1) + 1], &work[(*n << 1) + jb + + 1], &i__1, &iwork[1], &iinfo); + +/* Set INFO on the first occurence of Inf. */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } + + if (done) { + +/* Either the submatrix is zero before the end of the */ +/* column block, or ABSTOL or RELTOL criterion is */ +/* satisfied before the end of the column block, we can */ +/* return from the routine. Perform the following before */ +/* returning: */ +/* a) Set the number of factorized columns K, */ +/* K = IOFFSET + JBF from the last call of blocked */ +/* routine. */ +/* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned */ +/* by the block factorization routine; */ +/* 2) The remaining TAUs are set to ZERO by the */ +/* block factorization routine. */ + + *k = ioffset + jbf; + +/* Set INFO on the first occurrence of NaN, NaN takes */ +/* prcedence over Inf. */ + + if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + +/* Return from the routine. */ + + work[1] = (real) lwkopt; + + return 0; + + } + + j += jbf; + + } + + } + +/* Use unblocked code to factor the last or only block. */ +/* J = JMAX+1 means we factorized the maximum possible number of */ +/* columns, that is in ELSE clause we need to compute */ +/* the MAXC2NORM and RELMAXC2NORM to return after we processed */ +/* the blocks. */ + + if (j <= jmax) { + +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + n_sub__ = *n - j + 1; + ioffset = j - 1; + + i__1 = jmax - j + 1; + slaqp2rk_(m, &n_sub__, nrhs, &ioffset, &i__1, abstol, reltol, &kp1, & + maxc2nrm, &a[j * a_dim1 + 1], lda, &kf, maxc2nrmk, + relmaxc2nrmk, &jpiv[j], &tau[j], &work[j], &work[*n + j], & + work[(*n << 1) + 1], &iinfo); + +/* ABSTOL or RELTOL criterion is satisfied when the number of */ +/* the factorized columns KF is smaller then the number */ +/* of columns JMAX-J+1 supplied to be factorized by the */ +/* unblocked routine, we can return from */ +/* the routine. Perform the following before returning: */ +/* a) Set the number of factorized columns K, */ +/* b) MAXC2NRMK and RELMAXC2NRMK are returned by the */ +/* unblocked factorization routine above. */ + + *k = j - 1 + kf; + +/* Set INFO on the first exception occurence. */ + +/* Set INFO on the first exception occurence of Inf or NaN, */ +/* (NaN takes precedence over Inf). */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } else if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + + } else { + +/* Compute the return values for blocked code. */ + +/* Set the number of factorized columns if the unblocked routine */ +/* was not called. */ + + *k = jmax; + +/* If there exits a residual matrix after the blocked code: */ +/* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the */ +/* residual matrix, otherwise set them to ZERO; */ +/* 2) Set TAU(K+1:MINMN) to ZERO. */ + + if (*k < minmn) { + i__1 = *n - *k; + jmaxc2nrm = *k + isamax_(&i__1, &work[*k + 1], &c__1); + *maxc2nrmk = work[jmaxc2nrm]; + if (*k == 0) { + *relmaxc2nrmk = 1.f; + } else { + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + } + + i__1 = minmn; + for (j = *k + 1; j <= i__1; ++j) { + tau[j] = 0.f; + } + + } + +/* END IF( J.LE.JMAX ) THEN */ + + } + + work[1] = (real) lwkopt; + + return 0; + +/* End of SGEQP3RK */ + +} /* sgeqp3rk_ */ + diff --git a/lapack-netlib/SRC/slaqp2rk.c b/lapack-netlib/SRC/slaqp2rk.c new file mode 100644 index 000000000..0bfa71ab9 --- /dev/null +++ b/lapack-netlib/SRC/slaqp2rk.c @@ -0,0 +1,918 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + *info = *n + kk - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL >= ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL >= ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + +/* Set K, the number of factorized columns. */ + + *k = kk - 1; + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. */ + + i__2 = minmnfact; + for (j = kk; j <= i__2; ++j) { + tau[j] = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,KK:N): */ +/* 1) swap the KK-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) copy the KK-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than KK in the next loop step.) */ +/* 3) Save the pivot interchange with the indices relative to the */ +/* the original matrix A, not the block A(1:M,1:N). */ + + if (kp != kk) { + sswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1); + vn1[kp] = vn1[kk]; + vn2[kp] = vn2[kk]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[kk]; + jpiv[kk] = itemp; + } + +/* Generate elementary reflector H(KK) using the column A(I:M,KK), */ +/* if the column has more than one element, otherwise */ +/* the elementary reflector would be an identity matrix, */ +/* and TAU(KK) = ZERO. */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + slarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], & + c__1, &tau[kk]); + } else { + tau[kk] = 0.f; + } + +/* Check if TAU(KK) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(KK) for Inf, */ +/* since SLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by SLARFG can contain Inf, which requires */ +/* TAU(KK) to contain NaN. Therefore, this case of generating Inf */ +/* by SLARFG is covered by checking TAU(KK) for NaN. */ + + if (sisnan_(&tau[kk])) { + *k = kk - 1; + *info = kk; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = tau[kk]; + *relmaxc2nrmk = tau[kk]; + +/* Array TAU(KK:MINMNFACT) is not set and contains */ +/* undefined elements, except the first element TAU(KK) = NaN. */ + + return 0; + } + +/* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. */ +/* ( If M >= N, then at KK = N there is no residual matrix, */ +/* i.e. no columns of A to update, only columns of B. */ +/* If M < N, then at KK = M-IOFFSET, I = M and we have a */ +/* one-row residual matrix in A and the elementary */ +/* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update */ +/* is needed for the residual matrix in A and the */ +/* right-hand-side-matrix in B. */ +/* Therefore, we update only if */ +/* KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */ +/* condition is satisfied, not only KK < N+NRHS ) */ + + if (kk < minmnupdt) { + aikk = a[i__ + kk * a_dim1]; + a[i__ + kk * a_dim1] = 1.f; + i__2 = *m - i__ + 1; + i__3 = *n + *nrhs - kk; + slarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &tau[ + kk], &a[i__ + (kk + 1) * a_dim1], lda, &work[1]); + a[i__ + kk * a_dim1] = aikk; + } + + if (kk < minmnfact) { + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */ +/* when KK < f2cmin(M-IOFFSET, N). */ + + i__2 = *n; + for (j = kk + 1; j <= i__2; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)) / vn1[j]; + temp = 1.f - r__2 * r__2; + temp = f2cmax(temp,0.f); +/* Computing 2nd power */ + r__1 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + +/* Compute the column 2-norm for the partial */ +/* column A(I+1:M,J) by explicitly computing it, */ +/* and store it in both partial 2-norm vector VN1 */ +/* and exact column 2-norm vector VN2. */ + + i__3 = *m - i__; + vn1[j] = snrm2_(&i__3, &a[i__ + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + + } else { + +/* Update the column 2-norm for the partial */ +/* column A(I+1:M,J) by removing one */ +/* element A(I,J) and store it in partial */ +/* 2-norm vector VN1. */ + + vn1[j] *= sqrt(temp); + + } + } + } + + } + +/* End factorization loop */ + + } + +/* If we reached this point, all colunms have been factorized, */ +/* i.e. no condition was triggered to exit the routine. */ +/* Set the number of factorized columns. */ + + *k = *kmax; + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */ +/* we return. */ + + if (*k < minmnfact) { + + i__1 = *n - *k; + jmaxc2nrm = *k + isamax_(&i__1, &vn1[*k + 1], &c__1); + *maxc2nrmk = vn1[jmaxc2nrm]; + + if (*k == 0) { + *relmaxc2nrmk = 1.f; + } else { + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + } + + } else { + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + } + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, set TAUs corresponding to the columns that were */ +/* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. */ + + i__1 = minmnfact; + for (j = *k + 1; j <= i__1; ++j) { + tau[j] = 0.f; + } + + return 0; + +/* End of SLAQP2RK */ + +} /* slaqp2rk_ */ + diff --git a/lapack-netlib/SRC/slaqp3rk.c b/lapack-netlib/SRC/slaqp3rk.c new file mode 100644 index 000000000..e3632538b --- /dev/null +++ b/lapack-netlib/SRC/slaqp3rk.c @@ -0,0 +1,1109 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + sgemm_("No transpose", "Transpose", &i__1, nrhs, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* Quick return, if the submatrix A(I:M,K:N) is */ +/* a zero matrix. We need to check it only if the column index */ +/* (same as row index) is larger than 1, since the condition */ +/* for the whole original matrix A_orig is checked in the main */ +/* routine. */ + + if (*maxc2nrmk == 0.f) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *relmaxc2nrmk = 0.f; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix is zero and we stop the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + sgemm_("No transpose", "Transpose", &i__1, nrhs, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + tau[j] = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* Check if the submatrix A(I:M,K:N) contains Inf, */ +/* set INFO parameter to the column number, where */ +/* the first Inf is found plus N, and continue */ +/* the computation. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + if (*info == 0 && *maxc2nrmk > myhugeval) { + *info = *n + k - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third tolerance stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL.GE.ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig; */ + + *kb = k - 1; + if__ = i__ - 1; + +/* Apply the block reflector to the residual of the */ +/* matrix A and the residual of the right hand sides B, if */ +/* the residual matrix and and/or the residual of the right */ +/* hand sides exist, i.e. if the submatrix */ +/* A(I+1:M,KB+1:N+NRHS) exists. This occurs when */ +/* KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + sgemm_("No transpose", "Transpose", &i__1, &i__2, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*kb + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*kb + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + tau[j] = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,K:N): */ +/* 1) swap the K-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) */ +/* 3) copy the K-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. (Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than K in the next loop step.) */ +/* 4) Save the pivot interchange with the indices relative to the */ +/* the original matrix A_orig, not the block A(1:M,1:N). */ + + if (kp != k) { + sswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + sswap_(&i__1, &f[kp + f_dim1], ldf, &f[k + f_dim1], ldf); + vn1[kp] = vn1[k]; + vn2[kp] = vn2[k]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[k]; + jpiv[k] = itemp; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b7, &a[i__ + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b8, &a[i__ + k * a_dim1], &c__1); + } + +/* Generate elementary reflector H(k) using the column A(I:M,K). */ + + if (i__ < *m) { + i__1 = *m - i__ + 1; + slarfg_(&i__1, &a[i__ + k * a_dim1], &a[i__ + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + tau[k] = 0.f; + } + +/* Check if TAU(K) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(K) for Inf, */ +/* since SLARFG cannot produce TAU(K) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by SLARFG can contain Inf, which requires */ +/* TAU(K) to contain NaN. Therefore, this case of generating Inf */ +/* by SLARFG is covered by checking TAU(K) for NaN. */ + + if (sisnan_(&tau[k])) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *info = k; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = tau[k]; + *relmaxc2nrmk = tau[k]; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix contains NaN and we stop */ +/* the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + sgemm_("No transpose", "Transpose", &i__1, nrhs, kb, &c_b7, & + a[if__ + 1 + a_dim1], lda, &f[*n + 1 + f_dim1], ldf, & + c_b8, &a[if__ + 1 + (*n + 1) * a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* =============================================================== */ + + aik = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = 1.f; + +/* =============================================================== */ + +/* Compute the current K-th column of F: */ +/* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). */ + + if (k < *n + *nrhs) { + i__1 = *m - i__ + 1; + i__2 = *n + *nrhs - k; + sgemv_("Transpose", &i__1, &i__2, &tau[k], &a[i__ + (k + 1) * + a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b30, &f[k + + 1 + k * f_dim1], &c__1); + } + +/* 2) Zero out elements above and on the diagonal of the */ +/* column K in matrix F, i.e elements F(1:K,K). */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + f[j + k * f_dim1] = 0.f; + } + +/* 3) Incremental updating of the K-th column of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T */ +/* * A(I:M,K). */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + r__1 = -tau[k]; + sgemv_("Transpose", &i__1, &i__2, &r__1, &a[i__ + a_dim1], lda, & + a[i__ + k * a_dim1], &c__1, &c_b30, &auxv[1], &c__1); + + i__1 = *n + *nrhs; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b8, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b8, &f[k * f_dim1 + 1], &c__1); + } + +/* =============================================================== */ + +/* Update the current I-th row of A: */ +/* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) */ +/* - A(I,1:K)*F(K+1:N+NRHS,1:K)**T. */ + + if (k < *n + *nrhs) { + i__1 = *n + *nrhs - k; + sgemv_("No transpose", &i__1, &k, &c_b7, &f[k + 1 + f_dim1], ldf, + &a[i__ + a_dim1], lda, &c_b8, &a[i__ + (k + 1) * a_dim1], + lda); + } + + a[i__ + k * a_dim1] = aik; + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. */ +/* when K < MINMNFACT = f2cmin( M-IOFFSET, N ). */ + + if (k < minmnfact) { + + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)) / vn1[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 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + +/* At J-index, we have a difficult column for the */ +/* update of the 2-norm. Save the index of the previous */ +/* difficult column in IWORK(J-1). */ +/* NOTE: ILSTCC > 1, threfore we can use IWORK only */ +/* with N-1 elements, where the elements are */ +/* shifted by 1 to the left. */ + + iwork[j - 1] = lsticc; + +/* Set the index of the last difficult column LSTICC. */ + + lsticc = j; + + } else { + vn1[j] *= sqrt(temp); + } + } + } + + } + +/* End of while loop. */ + + } + +/* Now, afler the loop: */ +/* Set KB, the number of factorized columns in the block; */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig, IF = IOFFSET + KB. */ + + *kb = k; + if__ = i__; + +/* Apply the block reflector to the residual of the matrix A */ +/* and the residual of the right hand sides B, if the residual */ +/* matrix and and/or the residual of the right hand sides */ +/* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. */ +/* This occurs when KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + sgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b7, &a[if__ + + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b8, &a[if__ + + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recompute the 2-norm of the difficult columns. */ +/* Loop over the index of the difficult columns from the largest */ +/* to the smallest index. */ + + while(lsticc > 0) { + +/* LSTICC is the index of the last difficult column is greater */ +/* than 1. */ +/* ITEMP is the index of the previous difficult column. */ + + itemp = iwork[lsticc - 1]; + +/* Compute the 2-norm explicilty for the last difficult column and */ +/* save it in the partial and exact 2-norm vectors VN1 and VN2. */ + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* SNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(SLAMCH('S')) */ + + i__1 = *m - if__; + vn1[lsticc] = snrm2_(&i__1, &a[if__ + 1 + lsticc * a_dim1], &c__1); + vn2[lsticc] = vn1[lsticc]; + +/* Downdate the index of the last difficult column to */ +/* the index of the previous difficult column. */ + + lsticc = itemp; + + } + + return 0; + +/* End of SLAQP3RK */ + +} /* slaqp3rk_ */ + diff --git a/lapack-netlib/SRC/zgeqp3rk.c b/lapack-netlib/SRC/zgeqp3rk.c new file mode 100644 index 000000000..0c8b41c2d --- /dev/null +++ b/lapack-netlib/SRC/zgeqp3rk.c @@ -0,0 +1,1074 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + +/* Check if the matrix A contains +Inf or -Inf, set INFO parameter */ +/* to the column number, where the first +/-Inf is found plus N, */ +/* and continue the computation. */ + + *info = *n + kp1; + + } + +/* ================================================================== */ + +/* Quick return if possible for the case when the first */ +/* stopping criterion is satisfied, i.e. KMAX = 0. */ + + if (*kmax == 0) { + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.; + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + } + +/* ================================================================== */ + + eps = dlamch_("Epsilon"); + +/* Adjust ABSTOL */ + + if (*abstol >= 0.) { + safmin = dlamch_("Safe minimum"); +/* Computing MAX */ + d__1 = *abstol, d__2 = safmin * 2.; + *abstol = f2cmax(d__1,d__2); + } + +/* Adjust RELTOL */ + + if (*reltol >= 0.) { + *reltol = f2cmax(*reltol,eps); + } + +/* =================================================================== */ + +/* JMAX is the maximum index of the column to be factorized, */ +/* which is also limited by the first stopping criterion KMAX. */ + + jmax = f2cmin(*kmax,minmn); + +/* =================================================================== */ + +/* Quick return if possible for the case when the second or third */ +/* stopping criterion for the whole original matrix is satified, */ +/* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL */ +/* (which is ONE <= RELTOL). */ + + if (maxc2nrm <= *abstol || 1. <= *reltol) { + + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.; + + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + } + +/* ================================================================== */ +/* Factorize columns */ +/* ================================================================== */ + +/* Determine the block size. */ + + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < minmn) { + +/* Determine when to cross over from blocked to unblocked code. */ +/* (for N less than NX, unblocked code should be used). */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQP3RK", " ", m, n, &c_n1, &c_n1, ( + ftnlen)8, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + if (nx < minmn) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal block size that */ +/* is currently stored in NB. */ +/* Reduce NB and determine the minimum value of NB. */ + + nb = (*lwork - (*n << 1)) / (*n + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQP3RK", " ", m, n, &c_n1, + &c_n1, (ftnlen)8, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + } + } + } + +/* ================================================================== */ + +/* DONE is the boolean flag to rerpresent the case when the */ +/* factorization completed in the block factorization routine, */ +/* before the end of the block. */ + + done = FALSE_; + +/* J is the column index. */ + + j = 1; + +/* (1) Use blocked code initially. */ + +/* JMAXB is the maximum column index of the block, when the */ +/* blocked code is used, is also limited by the first stopping */ +/* criterion KMAX. */ + +/* Computing MIN */ + i__1 = *kmax, i__2 = minmn - nx; + jmaxb = f2cmin(i__1,i__2); + + if (nb >= nbmin && nb < jmax && jmaxb > 0) { + +/* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: */ +/* J is the column index of a column block; */ +/* JB is the column block size to pass to block factorization */ +/* routine in a loop step; */ +/* JBF is the number of columns that were actually factorized */ +/* that was returned by the block factorization routine */ +/* in a loop step, JBF <= JB; */ +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + while(j <= jmaxb) { + +/* Computing MIN */ + i__1 = nb, i__2 = jmaxb - j + 1; + jb = f2cmin(i__1,i__2); + n_sub__ = *n - j + 1; + ioffset = j - 1; + +/* Factorize JB columns among the columns A(J:N). */ + + i__1 = *n + *nrhs - j + 1; + zlaqp3rk_(m, &n_sub__, nrhs, &ioffset, &jb, abstol, reltol, &kp1, + &maxc2nrm, &a[j * a_dim1 + 1], lda, &done, &jbf, + maxc2nrmk, relmaxc2nrmk, &jpiv[j], &tau[j], &rwork[j], & + rwork[*n + j], &work[1], &work[jb + 1], &i__1, &iwork[1], + &iinfo); + +/* Set INFO on the first occurence of Inf. */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } + + if (done) { + +/* Either the submatrix is zero before the end of the */ +/* column block, or ABSTOL or RELTOL criterion is */ +/* satisfied before the end of the column block, we can */ +/* return from the routine. Perform the following before */ +/* returning: */ +/* a) Set the number of factorized columns K, */ +/* K = IOFFSET + JBF from the last call of blocked */ +/* routine. */ +/* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned */ +/* by the block factorization routine; */ +/* 2) The remaining TAUs are set to ZERO by the */ +/* block factorization routine. */ + + *k = ioffset + jbf; + +/* Set INFO on the first occurrence of NaN, NaN takes */ +/* prcedence over Inf. */ + + if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + +/* Return from the routine. */ + + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + + return 0; + + } + + j += jbf; + + } + + } + +/* Use unblocked code to factor the last or only block. */ +/* J = JMAX+1 means we factorized the maximum possible number of */ +/* columns, that is in ELSE clause we need to compute */ +/* the MAXC2NORM and RELMAXC2NORM to return after we processed */ +/* the blocks. */ + + if (j <= jmax) { + +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + n_sub__ = *n - j + 1; + ioffset = j - 1; + + i__1 = jmax - j + 1; + zlaqp2rk_(m, &n_sub__, nrhs, &ioffset, &i__1, abstol, reltol, &kp1, & + maxc2nrm, &a[j * a_dim1 + 1], lda, &kf, maxc2nrmk, + relmaxc2nrmk, &jpiv[j], &tau[j], &rwork[j], &rwork[*n + j], & + work[1], &iinfo); + +/* ABSTOL or RELTOL criterion is satisfied when the number of */ +/* the factorized columns KF is smaller then the number */ +/* of columns JMAX-J+1 supplied to be factorized by the */ +/* unblocked routine, we can return from */ +/* the routine. Perform the following before returning: */ +/* a) Set the number of factorized columns K, */ +/* b) MAXC2NRMK and RELMAXC2NRMK are returned by the */ +/* unblocked factorization routine above. */ + + *k = j - 1 + kf; + +/* Set INFO on the first exception occurence. */ + +/* Set INFO on the first exception occurence of Inf or NaN, */ +/* (NaN takes precedence over Inf). */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } else if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + + } else { + +/* Compute the return values for blocked code. */ + +/* Set the number of factorized columns if the unblocked routine */ +/* was not called. */ + + *k = jmax; + +/* If there exits a residual matrix after the blocked code: */ +/* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the */ +/* residual matrix, otherwise set them to ZERO; */ +/* 2) Set TAU(K+1:MINMN) to ZERO. */ + + if (*k < minmn) { + i__1 = *n - *k; + jmaxc2nrm = *k + idamax_(&i__1, &rwork[*k + 1], &c__1); + *maxc2nrmk = rwork[jmaxc2nrm]; + if (*k == 0) { + *relmaxc2nrmk = 1.; + } else { + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + } + + i__1 = minmn; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + + } else { + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + + } + +/* END IF( J.LE.JMAX ) THEN */ + + } + + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + + return 0; + +/* End of ZGEQP3RK */ + +} /* zgeqp3rk_ */ + diff --git a/lapack-netlib/SRC/zlaqp2rk.c b/lapack-netlib/SRC/zlaqp2rk.c new file mode 100644 index 000000000..0d38e71fb --- /dev/null +++ b/lapack-netlib/SRC/zlaqp2rk.c @@ -0,0 +1,947 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + *info = *n + kk - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL >= ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL >= ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + +/* Set K, the number of factorized columns. */ + + *k = kk - 1; + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. */ + + i__2 = minmnfact; + for (j = kk; j <= i__2; ++j) { + i__3 = j; + tau[i__3].r = 0., tau[i__3].i = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,KK:N): */ +/* 1) swap the KK-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) copy the KK-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than KK in the next loop step.) */ +/* 3) Save the pivot interchange with the indices relative to the */ +/* the original matrix A, not the block A(1:M,1:N). */ + + if (kp != kk) { + zswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1); + vn1[kp] = vn1[kk]; + vn2[kp] = vn2[kk]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[kk]; + jpiv[kk] = itemp; + } + +/* Generate elementary reflector H(KK) using the column A(I:M,KK), */ +/* if the column has more than one element, otherwise */ +/* the elementary reflector would be an identity matrix, */ +/* and TAU(KK) = CZERO. */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + zlarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], & + c__1, &tau[kk]); + } else { + i__2 = kk; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + +/* Check if TAU(KK) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(KK) for Inf, */ +/* since ZLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by ZLARFG can contain Inf, which requires */ +/* TAU(KK) to contain NaN. Therefore, this case of generating Inf */ +/* by ZLARFG is covered by checking TAU(KK) for NaN. */ + + i__2 = kk; + d__1 = tau[i__2].r; + if (disnan_(&d__1)) { + i__2 = kk; + taunan = tau[i__2].r; + } else /* if(complicated condition) */ { + d__1 = d_imag(&tau[kk]); + if (disnan_(&d__1)) { + taunan = d_imag(&tau[kk]); + } else { + taunan = 0.; + } + } + + if (disnan_(&taunan)) { + *k = kk - 1; + *info = kk; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = taunan; + *relmaxc2nrmk = taunan; + +/* Array TAU(KK:MINMNFACT) is not set and contains */ +/* undefined elements, except the first element TAU(KK) = NaN. */ + + return 0; + } + +/* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. */ +/* ( If M >= N, then at KK = N there is no residual matrix, */ +/* i.e. no columns of A to update, only columns of B. */ +/* If M < N, then at KK = M-IOFFSET, I = M and we have a */ +/* one-row residual matrix in A and the elementary */ +/* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update */ +/* is needed for the residual matrix in A and the */ +/* right-hand-side-matrix in B. */ +/* Therefore, we update only if */ +/* KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */ +/* condition is satisfied, not only KK < N+NRHS ) */ + + if (kk < minmnupdt) { + i__2 = i__ + kk * a_dim1; + aikk.r = a[i__2].r, aikk.i = a[i__2].i; + i__2 = i__ + kk * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - i__ + 1; + i__3 = *n + *nrhs - kk; + d_cnjg(&z__1, &tau[kk]); + zlarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &z__1, + &a[i__ + (kk + 1) * a_dim1], lda, &work[1]); + i__2 = i__ + kk * a_dim1; + a[i__2].r = aikk.r, a[i__2].i = aikk.i; + } + + if (kk < minmnfact) { + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */ +/* when KK < f2cmin(M-IOFFSET, N). */ + + i__2 = *n; + for (j = kk + 1; j <= i__2; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + d__1 = z_abs(&a[i__ + j * a_dim1]) / vn1[j]; + temp = 1. - d__1 * d__1; + temp = f2cmax(temp,0.); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + +/* Compute the column 2-norm for the partial */ +/* column A(I+1:M,J) by explicitly computing it, */ +/* and store it in both partial 2-norm vector VN1 */ +/* and exact column 2-norm vector VN2. */ + + i__3 = *m - i__; + vn1[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + + } else { + +/* Update the column 2-norm for the partial */ +/* column A(I+1:M,J) by removing one */ +/* element A(I,J) and store it in partial */ +/* 2-norm vector VN1. */ + + vn1[j] *= sqrt(temp); + + } + } + } + + } + +/* End factorization loop */ + + } + +/* If we reached this point, all colunms have been factorized, */ +/* i.e. no condition was triggered to exit the routine. */ +/* Set the number of factorized columns. */ + + *k = *kmax; + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */ +/* we return. */ + + if (*k < minmnfact) { + + i__1 = *n - *k; + jmaxc2nrm = *k + idamax_(&i__1, &vn1[*k + 1], &c__1); + *maxc2nrmk = vn1[jmaxc2nrm]; + + if (*k == 0) { + *relmaxc2nrmk = 1.; + } else { + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + } + + } else { + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + } + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, set TAUs corresponding to the columns that were */ +/* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. */ + + i__1 = minmnfact; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + + return 0; + +/* End of ZLAQP2RK */ + +} /* zlaqp2rk_ */ + diff --git a/lapack-netlib/SRC/zlaqp3rk.c b/lapack-netlib/SRC/zlaqp3rk.c new file mode 100644 index 000000000..cb44e4d34 --- /dev/null +++ b/lapack-netlib/SRC/zlaqp3rk.c @@ -0,0 +1,1157 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint 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; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +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;} +#endif +#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)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#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) = conjf(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) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_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 r_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_ri(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_ci(p, a, b) {pCf(p) = cpow_ui(Cf(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);} +#define mymaxloc_(w,s,e,n) 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; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +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; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +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; +} +#endif +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; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, + kb, &z__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* Quick return, if the submatrix A(I:M,K:N) is */ +/* a zero matrix. We need to check it only if the column index */ +/* (same as row index) is larger than 1, since the condition */ +/* for the whole original matrix A_orig is checked in the main */ +/* routine. */ + + if (*maxc2nrmk == 0.) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *relmaxc2nrmk = 0.; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix is zero and we stop the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, + kb, &z__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* Check if the submatrix A(I:M,K:N) contains Inf, */ +/* set INFO parameter to the column number, where */ +/* the first Inf is found plus N, and continue */ +/* the computation. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + if (*info == 0 && *maxc2nrmk > myhugeval) { + *info = *n + k - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third tolerance stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL.GE.ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig; */ + + *kb = k - 1; + if__ = i__ - 1; + +/* Apply the block reflector to the residual of the */ +/* matrix A and the residual of the right hand sides B, if */ +/* the residual matrix and and/or the residual of the right */ +/* hand sides exist, i.e. if the submatrix */ +/* A(I+1:M,KB+1:N+NRHS) exists. This occurs when */ +/* KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, & + i__2, kb, &z__1, &a[if__ + 1 + a_dim1], lda, &f[* + kb + 1 + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*kb + + 1) * a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,K:N): */ +/* 1) swap the K-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) */ +/* 3) copy the K-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. (Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than K in the next loop step.) */ +/* 4) Save the pivot interchange with the indices relative to the */ +/* the original matrix A_orig, not the block A(1:M,1:N). */ + + if (kp != k) { + zswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + zswap_(&i__1, &f[kp + f_dim1], ldf, &f[k + f_dim1], ldf); + vn1[kp] = vn1[k]; + vn2[kp] = vn2[k]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[k]; + jpiv[k] = itemp; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H. */ + + if (k > 1) { + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + d_cnjg(&z__1, &f[k + j * f_dim1]); + f[i__2].r = z__1.r, f[i__2].i = z__1.i; + } + i__1 = *m - i__ + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[i__ + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b2, &a[i__ + k * a_dim1], &c__1); + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + d_cnjg(&z__1, &f[k + j * f_dim1]); + f[i__2].r = z__1.r, f[i__2].i = z__1.i; + } + } + +/* Generate elementary reflector H(k) using the column A(I:M,K). */ + + if (i__ < *m) { + i__1 = *m - i__ + 1; + zlarfg_(&i__1, &a[i__ + k * a_dim1], &a[i__ + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + i__1 = k; + tau[i__1].r = 0., tau[i__1].i = 0.; + } + +/* Check if TAU(K) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(K) for Inf, */ +/* since ZLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by ZLARFG can contain Inf, which requires */ +/* TAU(K) to contain NaN. Therefore, this case of generating Inf */ +/* by ZLARFG is covered by checking TAU(K) for NaN. */ + + i__1 = k; + d__1 = tau[i__1].r; + if (disnan_(&d__1)) { + i__1 = k; + taunan = tau[i__1].r; + } else /* if(complicated condition) */ { + d__1 = d_imag(&tau[k]); + if (disnan_(&d__1)) { + taunan = d_imag(&tau[k]); + } else { + taunan = 0.; + } + } + + if (disnan_(&taunan)) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *info = k; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = taunan; + *relmaxc2nrmk = taunan; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix contains NaN and we stop */ +/* the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, kb, + &z__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * a_dim1], + lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* =============================================================== */ + + i__1 = i__ + k * a_dim1; + aik.r = a[i__1].r, aik.i = a[i__1].i; + i__1 = i__ + k * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + +/* =============================================================== */ + +/* Compute the current K-th column of F: */ +/* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K). */ + + if (k < *n + *nrhs) { + i__1 = *m - i__ + 1; + i__2 = *n + *nrhs - k; + zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[i__ + (k + + 1) * a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b1, & + f[k + 1 + k * f_dim1], &c__1); + } + +/* 2) Zero out elements above and on the diagonal of the */ +/* column K in matrix F, i.e elements F(1:K,K). */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + i__2 = j + k * f_dim1; + f[i__2].r = 0., f[i__2].i = 0.; + } + +/* 3) Incremental updating of the K-th column of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H */ +/* * A(I:M,K). */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + i__3 = k; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemv_("Conjugate Transpose", &i__1, &i__2, &z__1, &a[i__ + + a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b1, &auxv[1] + , &c__1); + + i__1 = *n + *nrhs; + i__2 = k - 1; + zgemv_("No transpose", &i__1, &i__2, &c_b2, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1); + } + +/* =============================================================== */ + +/* Update the current I-th row of A: */ +/* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) */ +/* - A(I,1:K)*F(K+1:N+NRHS,1:K)**H. */ + + if (k < *n + *nrhs) { + i__1 = *n + *nrhs - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, & + z__1, &a[i__ + a_dim1], lda, &f[k + 1 + f_dim1], ldf, & + c_b2, &a[i__ + (k + 1) * a_dim1], lda); + } + + i__1 = i__ + k * a_dim1; + a[i__1].r = aik.r, a[i__1].i = aik.i; + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. */ +/* when K < MINMNFACT = f2cmin( M-IOFFSET, N ). */ + + if (k < minmnfact) { + + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = z_abs(&a[i__ + j * a_dim1]) / vn1[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = f2cmax(d__1,d__2); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + +/* At J-index, we have a difficult column for the */ +/* update of the 2-norm. Save the index of the previous */ +/* difficult column in IWORK(J-1). */ +/* NOTE: ILSTCC > 1, threfore we can use IWORK only */ +/* with N-1 elements, where the elements are */ +/* shifted by 1 to the left. */ + + iwork[j - 1] = lsticc; + +/* Set the index of the last difficult column LSTICC. */ + + lsticc = j; + + } else { + vn1[j] *= sqrt(temp); + } + } + } + + } + +/* End of while loop. */ + + } + +/* Now, afler the loop: */ +/* Set KB, the number of factorized columns in the block; */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig, IF = IOFFSET + KB. */ + + *kb = k; + if__ = i__; + +/* Apply the block reflector to the residual of the matrix A */ +/* and the residual of the right hand sides B, if the residual */ +/* matrix and and/or the residual of the right hand sides */ +/* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. */ +/* This occurs when KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1, + &a[if__ + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, + &a[if__ + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recompute the 2-norm of the difficult columns. */ +/* Loop over the index of the difficult columns from the largest */ +/* to the smallest index. */ + + while(lsticc > 0) { + +/* LSTICC is the index of the last difficult column is greater */ +/* than 1. */ +/* ITEMP is the index of the previous difficult column. */ + + itemp = iwork[lsticc - 1]; + +/* Compute the 2-norm explicilty for the last difficult column and */ +/* save it in the partial and exact 2-norm vectors VN1 and VN2. */ + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* DZNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(DLAMCH('S')) */ + + i__1 = *m - if__; + vn1[lsticc] = dznrm2_(&i__1, &a[if__ + 1 + lsticc * a_dim1], &c__1); + vn2[lsticc] = vn1[lsticc]; + +/* Downdate the index of the last difficult column to */ +/* the index of the previous difficult column. */ + + lsticc = itemp; + + } + + return 0; + +/* End of ZLAQP3RK */ + +} /* zlaqp3rk_ */ +