Add C versions as fallback

lapack-netlib/SRC/DEPRECATED/cgelsx.c

@@ -0,0 +1,907 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* > \brief <b> CGELSX solves overdetermined or underdetermined systems for GE matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download CGELSX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cgelsx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cgelsx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cgelsx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */
+/*                          WORK, RWORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, LDB, M, N, NRHS, RANK */
+/*       REAL               RCOND */
+/*       INTEGER            JPVT( * ) */
+/*       REAL               RWORK( * ) */
+/*       COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine CGELSY. */
+/* > */
+/* > CGELSX computes the minimum-norm solution to a complex linear least */
+/* > squares problem: */
+/* >     minimize || A * X - B || */
+/* > using a complete orthogonal factorization of A.  A is an M-by-N */
+/* > matrix which may be rank-deficient. */
+/* > */
+/* > Several right hand side vectors b and solution vectors x can be */
+/* > handled in a single call; they are stored as the columns of the */
+/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* > matrix X. */
+/* > */
+/* > The routine first computes a QR factorization with column pivoting: */
+/* >     A * P = Q * [ R11 R12 ] */
+/* >                 [  0  R22 ] */
+/* > with R11 defined as the largest leading submatrix whose estimated */
+/* > condition number is less than 1/RCOND.  The order of R11, RANK, */
+/* > is the effective rank of A. */
+/* > */
+/* > Then, R22 is considered to be negligible, and R12 is annihilated */
+/* > by unitary transformations from the right, arriving at the */
+/* > complete orthogonal factorization: */
+/* >    A * P = Q * [ T11 0 ] * Z */
+/* >                [  0  0 ] */
+/* > The minimum-norm solution is then */
+/* >    X = P * Z**H [ inv(T11)*Q1**H*B ] */
+/* >                 [        0         ] */
+/* > where Q1 consists of the first RANK columns of Q. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of */
+/* >          columns of matrices B and X. NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A has been overwritten by details of its */
+/* >          complete orthogonal factorization. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is COMPLEX array, dimension (LDB,NRHS) */
+/* >          On entry, the M-by-NRHS right hand side matrix B. */
+/* >          On exit, the N-by-NRHS solution matrix X. */
+/* >          If m >= n and RANK = n, the residual sum-of-squares for */
+/* >          the solution in the i-th column is given by the sum of */
+/* >          squares of elements N+1:M in that column. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,M,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JPVT */
+/* > \verbatim */
+/* >          JPVT is INTEGER array, dimension (N) */
+/* >          On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
+/* >          initial column, otherwise it is a free column.  Before */
+/* >          the QR factorization of A, all initial columns are */
+/* >          permuted to the leading positions; only the remaining */
+/* >          free columns are moved as a result of column pivoting */
+/* >          during the factorization. */
+/* >          On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* >          was the k-th column of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RCOND */
+/* > \verbatim */
+/* >          RCOND is REAL */
+/* >          RCOND is used to determine the effective rank of A, which */
+/* >          is defined as the order of the largest leading triangular */
+/* >          submatrix R11 in the QR factorization with pivoting of A, */
+/* >          whose estimated condition number < 1/RCOND. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RANK */
+/* > \verbatim */
+/* >          RANK is INTEGER */
+/* >          The effective rank of A, i.e., the order of the submatrix */
+/* >          R11.  This is the same as the order of the submatrix T11 */
+/* >          in the complete orthogonal factorization of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX array, dimension */
+/* >                      (f2cmin(M,N) + f2cmax( N, 2*f2cmin(M,N)+NRHS )), */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RWORK */
+/* > \verbatim */
+/* >          RWORK is REAL array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complexGEsolve */
+
+/*  ===================================================================== */
+/* Subroutine */ int cgelsx_(integer *m, integer *n, integer *nrhs, complex *
+	a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond,
+	 integer *rank, complex *work, real *rwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+    complex q__1;
+
+    /* Local variables */
+    real anrm, bnrm, smin, smax;
+    integer i__, j, k, iascl, ibscl, ismin, ismax;
+    complex c1, c2;
+    extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, 
+	    integer *, integer *, complex *, complex *, integer *, complex *, 
+	    integer *), claic1_(integer *, 
+	    integer *, complex *, real *, complex *, complex *, real *, 
+	    complex *, complex *);
+    complex s1, s2, t1, t2;
+    extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *, 
+	    integer *, complex *, integer *, complex *, complex *, integer *, 
+	    complex *, integer *), slabad_(real *, real *);
+    extern real clange_(char *, integer *, integer *, complex *, integer *, 
+	    real *);
+    integer mn;
+    extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, 
+	    real *, integer *, integer *, complex *, integer *, integer *), cgeqpf_(integer *, integer *, complex *, integer *, 
+	    integer *, complex *, complex *, real *, integer *);
+    extern real slamch_(char *);
+    extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
+	    *, complex *, complex *, integer *), xerbla_(char *, 
+	    integer *);
+    real bignum;
+    extern /* Subroutine */ int clatzm_(char *, integer *, integer *, complex 
+	    *, integer *, complex *, complex *, complex *, integer *, complex 
+	    *);
+    real sminpr;
+    extern /* Subroutine */ int ctzrqf_(integer *, integer *, complex *, 
+	    integer *, complex *, integer *);
+    real smaxpr, smlnum;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --jpvt;
+    --work;
+    --rwork;
+
+    /* Function Body */
+    mn = f2cmin(*m,*n);
+    ismin = mn + 1;
+    ismax = (mn << 1) + 1;
+
+/*     Test the input arguments. */
+
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -5;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = f2cmax(1,*m);
+	if (*ldb < f2cmax(i__1,*n)) {
+	    *info = -7;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("CGELSX", &i__1);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+/* Computing MIN */
+    i__1 = f2cmin(*m,*n);
+    if (f2cmin(i__1,*nrhs) == 0) {
+	*rank = 0;
+	return 0;
+    }
+
+/*     Get machine parameters */
+
+    smlnum = slamch_("S") / slamch_("P");
+    bignum = 1.f / smlnum;
+    slabad_(&smlnum, &bignum);
+
+/*     Scale A, B if f2cmax elements outside range [SMLNUM,BIGNUM] */
+
+    anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+    iascl = 0;
+    if (anrm > 0.f && anrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 1;
+    } else if (anrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 2;
+    } else if (anrm == 0.f) {
+
+/*        Matrix all zero. Return zero solution. */
+
+	i__1 = f2cmax(*m,*n);
+	claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+	*rank = 0;
+	goto L100;
+    }
+
+    bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+    ibscl = 0;
+    if (bnrm > 0.f && bnrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+		 info);
+	ibscl = 1;
+    } else if (bnrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+		 info);
+	ibscl = 2;
+    }
+
+/*     Compute QR factorization with column pivoting of A: */
+/*        A * P = Q * R */
+
+    cgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &
+	    rwork[1], info);
+
+/*     complex workspace MN+N. Real workspace 2*N. Details of Householder */
+/*     rotations stored in WORK(1:MN). */
+
+/*     Determine RANK using incremental condition estimation */
+
+    i__1 = ismin;
+    work[i__1].r = 1.f, work[i__1].i = 0.f;
+    i__1 = ismax;
+    work[i__1].r = 1.f, work[i__1].i = 0.f;
+    smax = c_abs(&a[a_dim1 + 1]);
+    smin = smax;
+    if (c_abs(&a[a_dim1 + 1]) == 0.f) {
+	*rank = 0;
+	i__1 = f2cmax(*m,*n);
+	claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+	goto L100;
+    } else {
+	*rank = 1;
+    }
+
+L10:
+    if (*rank < mn) {
+	i__ = *rank + 1;
+	claic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+		i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+	claic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+		i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+	if (smaxpr * *rcond <= sminpr) {
+	    i__1 = *rank;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		i__2 = ismin + i__ - 1;
+		i__3 = ismin + i__ - 1;
+		q__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, q__1.i = 
+			s1.r * work[i__3].i + s1.i * work[i__3].r;
+		work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+		i__2 = ismax + i__ - 1;
+		i__3 = ismax + i__ - 1;
+		q__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, q__1.i = 
+			s2.r * work[i__3].i + s2.i * work[i__3].r;
+		work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L20: */
+	    }
+	    i__1 = ismin + *rank;
+	    work[i__1].r = c1.r, work[i__1].i = c1.i;
+	    i__1 = ismax + *rank;
+	    work[i__1].r = c2.r, work[i__1].i = c2.i;
+	    smin = sminpr;
+	    smax = smaxpr;
+	    ++(*rank);
+	    goto L10;
+	}
+    }
+
+/*     Logically partition R = [ R11 R12 ] */
+/*                             [  0  R22 ] */
+/*     where R11 = R(1:RANK,1:RANK) */
+
+/*     [R11,R12] = [ T11, 0 ] * Y */
+
+    if (*rank < *n) {
+	ctzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
+    }
+
+/*     Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/*     B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS) */
+
+    cunm2r_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, &
+	    work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], info);
+
+/*     workspace NRHS */
+
+/*      B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+    ctrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[
+	    a_offset], lda, &b[b_offset], ldb);
+
+    i__1 = *n;
+    for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+	i__2 = *nrhs;
+	for (j = 1; j <= i__2; ++j) {
+	    i__3 = i__ + j * b_dim1;
+	    b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L30: */
+	}
+/* L40: */
+    }
+
+/*     B(1:N,1:NRHS) := Y**H * B(1:N,1:NRHS) */
+
+    if (*rank < *n) {
+	i__1 = *rank;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n - *rank + 1;
+	    r_cnjg(&q__1, &work[mn + i__]);
+	    clatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, 
+		    &q__1, &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], ldb, &
+		    work[(mn << 1) + 1]);
+/* L50: */
+	}
+    }
+
+/*     workspace NRHS */
+
+/*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+    i__1 = *nrhs;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = (mn << 1) + i__;
+	    work[i__3].r = 1.f, work[i__3].i = 0.f;
+/* L60: */
+	}
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = (mn << 1) + i__;
+	    if (work[i__3].r == 1.f && work[i__3].i == 0.f) {
+		if (jpvt[i__] != i__) {
+		    k = i__;
+		    i__3 = k + j * b_dim1;
+		    t1.r = b[i__3].r, t1.i = b[i__3].i;
+		    i__3 = jpvt[k] + j * b_dim1;
+		    t2.r = b[i__3].r, t2.i = b[i__3].i;
+L70:
+		    i__3 = jpvt[k] + j * b_dim1;
+		    b[i__3].r = t1.r, b[i__3].i = t1.i;
+		    i__3 = (mn << 1) + k;
+		    work[i__3].r = 0.f, work[i__3].i = 0.f;
+		    t1.r = t2.r, t1.i = t2.i;
+		    k = jpvt[k];
+		    i__3 = jpvt[k] + j * b_dim1;
+		    t2.r = b[i__3].r, t2.i = b[i__3].i;
+		    if (jpvt[k] != i__) {
+			goto L70;
+		    }
+		    i__3 = i__ + j * b_dim1;
+		    b[i__3].r = t1.r, b[i__3].i = t1.i;
+		    i__3 = (mn << 1) + k;
+		    work[i__3].r = 0.f, work[i__3].i = 0.f;
+		}
+	    }
+/* L80: */
+	}
+/* L90: */
+    }
+
+/*     Undo scaling */
+
+    if (iascl == 1) {
+	clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+		 info);
+	clascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], 
+		lda, info);
+    } else if (iascl == 2) {
+	clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+		 info);
+	clascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], 
+		lda, info);
+    }
+    if (ibscl == 1) {
+	clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+		 info);
+    } else if (ibscl == 2) {
+	clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+		 info);
+    }
+
+L100:
+
+    return 0;
+
+/*     End of CGELSX */
+
+} /* cgelsx_ */
+

lapack-netlib/SRC/DEPRECATED/cgeqpf.c

@@ -0,0 +1,743 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* > \brief \b CGEQPF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download CGEQPF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cgeqpf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cgeqpf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cgeqpf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, M, N */
+/*       INTEGER            JPVT( * ) */
+/*       REAL               RWORK( * ) */
+/*       COMPLEX            A( LDA, * ), TAU( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine CGEQP3. */
+/* > */
+/* > CGEQPF computes a QR factorization with column pivoting of a */
+/* > complex M-by-N matrix A: A*P = Q*R. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A. M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A. N >= 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, the upper triangle of the array contains the */
+/* >          f2cmin(M,N)-by-N upper triangular matrix R; the elements */
+/* >          below the diagonal, together with the array TAU, */
+/* >          represent the unitary matrix Q as a product of */
+/* >          f2cmin(m,n) elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JPVT */
+/* > \verbatim */
+/* >          JPVT is INTEGER array, dimension (N) */
+/* >          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* >          to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* >          the i-th column of A is a free column. */
+/* >          On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* >          was the k-th column of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is COMPLEX array, dimension (f2cmin(M,N)) */
+/* >          The scalar factors of the elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RWORK */
+/* > \verbatim */
+/* >          RWORK is REAL array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complexGEcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The matrix Q is represented as a product of elementary reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(n) */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H = I - tau * v * v**H */
+/* > */
+/* >  where tau is a complex scalar, and v is a complex vector with */
+/* >  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
+/* > */
+/* >  The matrix P is represented in jpvt as follows: If */
+/* >     jpvt(j) = i */
+/* >  then the jth column of P is the ith canonical unit vector. */
+/* > */
+/* >  Partial column norm updating strategy modified by */
+/* >    Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* >    University of Zagreb, Croatia. */
+/* >  -- April 2011                                                      -- */
+/* >  For more details see LAPACK Working Note 176. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int cgeqpf_(integer *m, integer *n, complex *a, integer *lda,
+	 integer *jpvt, complex *tau, complex *work, real *rwork, integer *
+	info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    real r__1, r__2;
+    complex q__1;
+
+    /* Local variables */
+    real temp, temp2;
+    integer i__, j;
+    real tol3z;
+    extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+	    , integer *, complex *, complex *, integer *, complex *), 
+	    cswap_(integer *, complex *, integer *, complex *, integer *);
+    integer itemp;
+    extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *, 
+	    integer *, complex *, complex *, integer *);
+    extern real scnrm2_(integer *, complex *, integer *);
+    extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *, 
+	    integer *, complex *, integer *, complex *, complex *, integer *, 
+	    complex *, integer *);
+    integer ma, mn;
+    extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, 
+	    integer *, complex *);
+    extern real slamch_(char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    extern integer isamax_(integer *, real *, integer *);
+    complex aii;
+    integer pvt;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --jpvt;
+    --tau;
+    --work;
+    --rwork;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("CGEQPF", &i__1);
+	return 0;
+    }
+
+    mn = f2cmin(*m,*n);
+    tol3z = sqrt(slamch_("Epsilon"));
+
+/*     Move initial columns up front */
+
+    itemp = 1;
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (jpvt[i__] != 0) {
+	    if (i__ != itemp) {
+		cswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
+			 &c__1);
+		jpvt[i__] = jpvt[itemp];
+		jpvt[itemp] = i__;
+	    } else {
+		jpvt[i__] = i__;
+	    }
+	    ++itemp;
+	} else {
+	    jpvt[i__] = i__;
+	}
+/* L10: */
+    }
+    --itemp;
+
+/*     Compute the QR factorization and update remaining columns */
+
+    if (itemp > 0) {
+	ma = f2cmin(itemp,*m);
+	cgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
+	if (ma < *n) {
+	    i__1 = *n - ma;
+	    cunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
+		    , lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], 
+		    info);
+	}
+    }
+
+    if (itemp < mn) {
+
+/*        Initialize partial column norms. The first n elements of */
+/*        work store the exact column norms. */
+
+	i__1 = *n;
+	for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+	    i__2 = *m - itemp;
+	    rwork[i__] = scnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
+	    rwork[*n + i__] = rwork[i__];
+/* L20: */
+	}
+
+/*        Compute factorization */
+
+	i__1 = mn;
+	for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+
+/*           Determine ith pivot column and swap if necessary */
+
+	    i__2 = *n - i__ + 1;
+	    pvt = i__ - 1 + isamax_(&i__2, &rwork[i__], &c__1);
+
+	    if (pvt != i__) {
+		cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+			c__1);
+		itemp = jpvt[pvt];
+		jpvt[pvt] = jpvt[i__];
+		jpvt[i__] = itemp;
+		rwork[pvt] = rwork[i__];
+		rwork[*n + pvt] = rwork[*n + i__];
+	    }
+
+/*           Generate elementary reflector H(i) */
+
+	    i__2 = i__ + i__ * a_dim1;
+	    aii.r = a[i__2].r, aii.i = a[i__2].i;
+	    i__2 = *m - i__ + 1;
+/* Computing MIN */
+	    i__3 = i__ + 1;
+	    clarfg_(&i__2, &aii, &a[f2cmin(i__3,*m) + i__ * a_dim1], &c__1, &tau[
+		    i__]);
+	    i__2 = i__ + i__ * a_dim1;
+	    a[i__2].r = aii.r, a[i__2].i = aii.i;
+
+	    if (i__ < *n) {
+
+/*              Apply H(i) to A(i:m,i+1:n) from the left */
+
+		i__2 = i__ + i__ * a_dim1;
+		aii.r = a[i__2].r, aii.i = a[i__2].i;
+		i__2 = i__ + i__ * a_dim1;
+		a[i__2].r = 1.f, a[i__2].i = 0.f;
+		i__2 = *m - i__ + 1;
+		i__3 = *n - i__;
+		r_cnjg(&q__1, &tau[i__]);
+		clarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+			q__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+		i__2 = i__ + i__ * a_dim1;
+		a[i__2].r = aii.r, a[i__2].i = aii.i;
+	    }
+
+/*           Update partial column norms */
+
+	    i__2 = *n;
+	    for (j = i__ + 1; j <= i__2; ++j) {
+		if (rwork[j] != 0.f) {
+
+/*                 NOTE: The following 4 lines follow from the analysis in */
+/*                 Lapack Working Note 176. */
+
+		    temp = c_abs(&a[i__ + j * a_dim1]) / rwork[j];
+/* Computing MAX */
+		    r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
+		    temp = f2cmax(r__1,r__2);
+/* Computing 2nd power */
+		    r__1 = rwork[j] / rwork[*n + j];
+		    temp2 = temp * (r__1 * r__1);
+		    if (temp2 <= tol3z) {
+			if (*m - i__ > 0) {
+			    i__3 = *m - i__;
+			    rwork[j] = scnrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
+				    , &c__1);
+			    rwork[*n + j] = rwork[j];
+			} else {
+			    rwork[j] = 0.f;
+			    rwork[*n + j] = 0.f;
+			}
+		    } else {
+			rwork[j] *= sqrt(temp);
+		    }
+		}
+/* L30: */
+	    }
+
+/* L40: */
+	}
+    }
+    return 0;
+
+/*     End of CGEQPF */
+
+} /* cgeqpf_ */
+

lapack-netlib/SRC/DEPRECATED/cggsvd.c

@@ -0,0 +1,889 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* > \brief <b> CGGSVD computes the singular value decomposition (SVD) for OTHER matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download CGGSVD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cggsvd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cggsvd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cggsvd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */
+/*                          LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */
+/*                          RWORK, IWORK, INFO ) */
+
+/*       CHARACTER          JOBQ, JOBU, JOBV */
+/*       INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               ALPHA( * ), BETA( * ), RWORK( * ) */
+/*       COMPLEX            A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */
+/*      $                   U( LDU, * ), V( LDV, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine CGGSVD3. */
+/* > */
+/* > CGGSVD computes the generalized singular value decomposition (GSVD) */
+/* > of an M-by-N complex matrix A and P-by-N complex matrix B: */
+/* > */
+/* >       U**H*A*Q = D1*( 0 R ),    V**H*B*Q = D2*( 0 R ) */
+/* > */
+/* > where U, V and Q are unitary matrices. */
+/* > Let K+L = the effective numerical rank of the */
+/* > matrix (A**H,B**H)**H, then R is a (K+L)-by-(K+L) nonsingular upper */
+/* > triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal" */
+/* > matrices and of the following structures, respectively: */
+/* > */
+/* > If M-K-L >= 0, */
+/* > */
+/* >                     K  L */
+/* >        D1 =     K ( I  0 ) */
+/* >                 L ( 0  C ) */
+/* >             M-K-L ( 0  0 ) */
+/* > */
+/* >                   K  L */
+/* >        D2 =   L ( 0  S ) */
+/* >             P-L ( 0  0 ) */
+/* > */
+/* >                 N-K-L  K    L */
+/* >   ( 0 R ) = K (  0   R11  R12 ) */
+/* >             L (  0    0   R22 ) */
+/* > */
+/* > where */
+/* > */
+/* >   C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* >   S = diag( BETA(K+1),  ... , BETA(K+L) ), */
+/* >   C**2 + S**2 = I. */
+/* > */
+/* >   R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+/* > */
+/* > If M-K-L < 0, */
+/* > */
+/* >                   K M-K K+L-M */
+/* >        D1 =   K ( I  0    0   ) */
+/* >             M-K ( 0  C    0   ) */
+/* > */
+/* >                     K M-K K+L-M */
+/* >        D2 =   M-K ( 0  S    0  ) */
+/* >             K+L-M ( 0  0    I  ) */
+/* >               P-L ( 0  0    0  ) */
+/* > */
+/* >                    N-K-L  K   M-K  K+L-M */
+/* >   ( 0 R ) =     K ( 0    R11  R12  R13  ) */
+/* >               M-K ( 0     0   R22  R23  ) */
+/* >             K+L-M ( 0     0    0   R33  ) */
+/* > */
+/* > where */
+/* > */
+/* >   C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* >   S = diag( BETA(K+1),  ... , BETA(M) ), */
+/* >   C**2 + S**2 = I. */
+/* > */
+/* >   (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */
+/* >   ( 0  R22 R23 ) */
+/* >   in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+/* > */
+/* > The routine computes C, S, R, and optionally the unitary */
+/* > transformation matrices U, V and Q. */
+/* > */
+/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */
+/* > A and B implicitly gives the SVD of A*inv(B): */
+/* >                      A*inv(B) = U*(D1*inv(D2))*V**H. */
+/* > If ( A**H,B**H)**H has orthnormal columns, then the GSVD of A and B is also */
+/* > equal to the CS decomposition of A and B. Furthermore, the GSVD can */
+/* > be used to derive the solution of the eigenvalue problem: */
+/* >                      A**H*A x = lambda* B**H*B x. */
+/* > In some literature, the GSVD of A and B is presented in the form */
+/* >                  U**H*A*X = ( 0 D1 ),   V**H*B*X = ( 0 D2 ) */
+/* > where U and V are orthogonal and X is nonsingular, and D1 and D2 are */
+/* > ``diagonal''.  The former GSVD form can be converted to the latter */
+/* > form by taking the nonsingular matrix X as */
+/* > */
+/* >                       X = Q*(  I   0    ) */
+/* >                             (  0 inv(R) ) */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBU */
+/* > \verbatim */
+/* >          JOBU is CHARACTER*1 */
+/* >          = 'U':  Unitary matrix U is computed; */
+/* >          = 'N':  U is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBV */
+/* > \verbatim */
+/* >          JOBV is CHARACTER*1 */
+/* >          = 'V':  Unitary matrix V is computed; */
+/* >          = 'N':  V is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBQ */
+/* > \verbatim */
+/* >          JOBQ is CHARACTER*1 */
+/* >          = 'Q':  Unitary matrix Q is computed; */
+/* >          = 'N':  Q is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] P */
+/* > \verbatim */
+/* >          P is INTEGER */
+/* >          The number of rows of the matrix B.  P >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* > \endverbatim */
+/* > */
+/* > \param[out] L */
+/* > \verbatim */
+/* >          L is INTEGER */
+/* > */
+/* >          On exit, K and L specify the dimension of the subblocks */
+/* >          described in Purpose. */
+/* >          K + L = effective numerical rank of (A**H,B**H)**H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A contains the triangular matrix R, or part of R. */
+/* >          See Purpose for details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is COMPLEX array, dimension (LDB,N) */
+/* >          On entry, the P-by-N matrix B. */
+/* >          On exit, B contains part of the triangular matrix R if */
+/* >          M-K-L < 0.  See Purpose for details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,P). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] BETA */
+/* > \verbatim */
+/* >          BETA is REAL array, dimension (N) */
+/* > */
+/* >          On exit, ALPHA and BETA contain the generalized singular */
+/* >          value pairs of A and B; */
+/* >            ALPHA(1:K) = 1, */
+/* >            BETA(1:K)  = 0, */
+/* >          and if M-K-L >= 0, */
+/* >            ALPHA(K+1:K+L) = C, */
+/* >            BETA(K+1:K+L)  = S, */
+/* >          or if M-K-L < 0, */
+/* >            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */
+/* >            BETA(K+1:M) =S, BETA(M+1:K+L) =1 */
+/* >          and */
+/* >            ALPHA(K+L+1:N) = 0 */
+/* >            BETA(K+L+1:N)  = 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[out] U */
+/* > \verbatim */
+/* >          U is COMPLEX array, dimension (LDU,M) */
+/* >          If JOBU = 'U', U contains the M-by-M unitary matrix U. */
+/* >          If JOBU = 'N', U is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDU */
+/* > \verbatim */
+/* >          LDU is INTEGER */
+/* >          The leading dimension of the array U. LDU >= f2cmax(1,M) if */
+/* >          JOBU = 'U'; LDU >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] V */
+/* > \verbatim */
+/* >          V is COMPLEX array, dimension (LDV,P) */
+/* >          If JOBV = 'V', V contains the P-by-P unitary matrix V. */
+/* >          If JOBV = 'N', V is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDV */
+/* > \verbatim */
+/* >          LDV is INTEGER */
+/* >          The leading dimension of the array V. LDV >= f2cmax(1,P) if */
+/* >          JOBV = 'V'; LDV >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Q */
+/* > \verbatim */
+/* >          Q is COMPLEX array, dimension (LDQ,N) */
+/* >          If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q. */
+/* >          If JOBQ = 'N', Q is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDQ */
+/* > \verbatim */
+/* >          LDQ is INTEGER */
+/* >          The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */
+/* >          JOBQ = 'Q'; LDQ >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX array, dimension (f2cmax(3*N,M,P)+N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RWORK */
+/* > \verbatim */
+/* >          RWORK is REAL array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* >          On exit, IWORK stores the sorting information. More */
+/* >          precisely, the following loop will sort ALPHA */
+/* >             for I = K+1, f2cmin(M,K+L) */
+/* >                 swap ALPHA(I) and ALPHA(IWORK(I)) */
+/* >             endfor */
+/* >          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit. */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* >          > 0:  if INFO = 1, the Jacobi-type procedure failed to */
+/* >                converge.  For further details, see subroutine CTGSJA. */
+/* > \endverbatim */
+
+/* > \par Internal Parameters: */
+/*  ========================= */
+/* > */
+/* > \verbatim */
+/* >  TOLA    REAL */
+/* >  TOLB    REAL */
+/* >          TOLA and TOLB are the thresholds to determine the effective */
+/* >          rank of (A**H,B**H)**H. Generally, they are set to */
+/* >                   TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* >                   TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+/* >          The size of TOLA and TOLB may affect the size of backward */
+/* >          errors of the decomposition. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complexOTHERsing */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* >     Ming Gu and Huan Ren, Computer Science Division, University of */
+/* >     California at Berkeley, USA */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int cggsvd_(char *jobu, char *jobv, char *jobq, integer *m, 
+	integer *n, integer *p, integer *k, integer *l, complex *a, integer *
+	lda, complex *b, integer *ldb, real *alpha, real *beta, complex *u, 
+	integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, 
+	complex *work, real *rwork, integer *iwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, 
+	    u_offset, v_dim1, v_offset, i__1, i__2;
+
+    /* Local variables */
+    integer ibnd;
+    real tola;
+    integer isub;
+    real tolb, unfl, temp, smax;
+    integer ncallmycycle, i__, j;
+    extern logical lsame_(char *, char *);
+    real anorm, bnorm;
+    logical wantq;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *);
+    logical wantu, wantv;
+    extern real clange_(char *, integer *, integer *, complex *, integer *, 
+	    real *), slamch_(char *);
+    extern /* Subroutine */ int ctgsja_(char *, char *, char *, integer *, 
+	    integer *, integer *, integer *, integer *, complex *, integer *, 
+	    complex *, integer *, real *, real *, real *, real *, complex *, 
+	    integer *, complex *, integer *, complex *, integer *, complex *, 
+	    integer *, integer *), xerbla_(char *, 
+	    integer *), cggsvp_(char *, char *, char *, integer *, 
+	    integer *, integer *, complex *, integer *, complex *, integer *, 
+	    real *, real *, integer *, integer *, complex *, integer *, 
+	    complex *, integer *, complex *, integer *, integer *, real *, 
+	    complex *, complex *, integer *);
+    real ulp;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Decode and test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --alpha;
+    --beta;
+    u_dim1 = *ldu;
+    u_offset = 1 + u_dim1 * 1;
+    u -= u_offset;
+    v_dim1 = *ldv;
+    v_offset = 1 + v_dim1 * 1;
+    v -= v_offset;
+    q_dim1 = *ldq;
+    q_offset = 1 + q_dim1 * 1;
+    q -= q_offset;
+    --work;
+    --rwork;
+    --iwork;
+
+    /* Function Body */
+    wantu = lsame_(jobu, "U");
+    wantv = lsame_(jobv, "V");
+    wantq = lsame_(jobq, "Q");
+
+    *info = 0;
+    if (! (wantu || lsame_(jobu, "N"))) {
+	*info = -1;
+    } else if (! (wantv || lsame_(jobv, "N"))) {
+	*info = -2;
+    } else if (! (wantq || lsame_(jobq, "N"))) {
+	*info = -3;
+    } else if (*m < 0) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -5;
+    } else if (*p < 0) {
+	*info = -6;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -10;
+    } else if (*ldb < f2cmax(1,*p)) {
+	*info = -12;
+    } else if (*ldu < 1 || wantu && *ldu < *m) {
+	*info = -16;
+    } else if (*ldv < 1 || wantv && *ldv < *p) {
+	*info = -18;
+    } else if (*ldq < 1 || wantq && *ldq < *n) {
+	*info = -20;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("CGGSVD", &i__1);
+	return 0;
+    }
+
+/*     Compute the Frobenius norm of matrices A and B */
+
+    anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+    bnorm = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+
+/*     Get machine precision and set up threshold for determining */
+/*     the effective numerical rank of the matrices A and B. */
+
+    ulp = slamch_("Precision");
+    unfl = slamch_("Safe Minimum");
+    tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp;
+    tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp;
+
+    cggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, &
+	    tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[
+	    q_offset], ldq, &iwork[1], &rwork[1], &work[1], &work[*n + 1], 
+	    info);
+
+/*     Compute the GSVD of two upper "triangular" matrices */
+
+    ctgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], 
+	    ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+	    v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info);
+
+/*     Sort the singular values and store the pivot indices in IWORK */
+/*     Copy ALPHA to RWORK, then sort ALPHA in RWORK */
+
+    scopy_(n, &alpha[1], &c__1, &rwork[1], &c__1);
+/* Computing MIN */
+    i__1 = *l, i__2 = *m - *k;
+    ibnd = f2cmin(i__1,i__2);
+    i__1 = ibnd;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        Scan for largest ALPHA(K+I) */
+
+	isub = i__;
+	smax = rwork[*k + i__];
+	i__2 = ibnd;
+	for (j = i__ + 1; j <= i__2; ++j) {
+	    temp = rwork[*k + j];
+	    if (temp > smax) {
+		isub = j;
+		smax = temp;
+	    }
+/* L10: */
+	}
+	if (isub != i__) {
+	    rwork[*k + isub] = rwork[*k + i__];
+	    rwork[*k + i__] = smax;
+	    iwork[*k + i__] = *k + isub;
+	} else {
+	    iwork[*k + i__] = *k + i__;
+	}
+/* L20: */
+    }
+
+    return 0;
+
+/*     End of CGGSVD */
+
+} /* cggsvd_ */
+

lapack-netlib/SRC/DEPRECATED/clahrd.c

@@ -0,0 +1,734 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* > \brief \b CLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below th
+e k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformati
+on to the unreduced part of A. */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download CLAHRD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clahrd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clahrd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clahrd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */
+
+/*       INTEGER            K, LDA, LDT, LDY, N, NB */
+/*       COMPLEX            A( LDA, * ), T( LDT, NB ), TAU( NB ), */
+/*      $                   Y( LDY, NB ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine CLAHR2. */
+/* > */
+/* > CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) */
+/* > matrix A so that elements below the k-th subdiagonal are zero. The */
+/* > reduction is performed by a unitary similarity transformation */
+/* > Q**H * A * Q. The routine returns the matrices V and T which determine */
+/* > Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The offset for the reduction. Elements below the k-th */
+/* >          subdiagonal in the first NB columns are reduced to zero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NB */
+/* > \verbatim */
+/* >          NB is INTEGER */
+/* >          The number of columns to be reduced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N-K+1) */
+/* >          On entry, the n-by-(n-k+1) general matrix A. */
+/* >          On exit, the elements on and above the k-th subdiagonal in */
+/* >          the first NB columns are overwritten with the corresponding */
+/* >          elements of the reduced matrix; the elements below the k-th */
+/* >          subdiagonal, with the array TAU, represent the matrix Q as a */
+/* >          product of elementary reflectors. The other columns of A are */
+/* >          unchanged. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is COMPLEX array, dimension (NB) */
+/* >          The scalar factors of the elementary reflectors. See Further */
+/* >          Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] T */
+/* > \verbatim */
+/* >          T is COMPLEX array, dimension (LDT,NB) */
+/* >          The upper triangular matrix T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDT */
+/* > \verbatim */
+/* >          LDT is INTEGER */
+/* >          The leading dimension of the array T.  LDT >= NB. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Y */
+/* > \verbatim */
+/* >          Y is COMPLEX array, dimension (LDY,NB) */
+/* >          The n-by-nb matrix Y. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDY */
+/* > \verbatim */
+/* >          LDY is INTEGER */
+/* >          The leading dimension of the array Y. LDY >= f2cmax(1,N). */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complexOTHERauxiliary */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The matrix Q is represented as a product of nb elementary reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(nb). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**H */
+/* > */
+/* >  where tau is a complex scalar, and v is a complex vector with */
+/* >  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* >  A(i+k+1:n,i), and tau in TAU(i). */
+/* > */
+/* >  The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* >  V which is needed, with T and Y, to apply the transformation to the */
+/* >  unreduced part of the matrix, using an update of the form: */
+/* >  A := (I - V*T*V**H) * (A - Y*V**H). */
+/* > */
+/* >  The contents of A on exit are illustrated by the following example */
+/* >  with n = 7, k = 3 and nb = 2: */
+/* > */
+/* >     ( a   h   a   a   a ) */
+/* >     ( a   h   a   a   a ) */
+/* >     ( a   h   a   a   a ) */
+/* >     ( h   h   a   a   a ) */
+/* >     ( v1  h   a   a   a ) */
+/* >     ( v1  v2  a   a   a ) */
+/* >     ( v1  v2  a   a   a ) */
+/* > */
+/* >  where a denotes an element of the original matrix A, h denotes a */
+/* >  modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* >  element of the vector defining H(i). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int clahrd_(integer *n, integer *k, integer *nb, complex *a, 
+	integer *lda, complex *tau, complex *t, integer *ldt, complex *y, 
+	integer *ldy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, 
+	    i__3;
+    complex q__1;
+
+    /* Local variables */
+    integer i__;
+    extern /* Subroutine */ int cscal_(integer *, complex *, complex *, 
+	    integer *), cgemv_(char *, integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, complex *, 
+	    integer *), ccopy_(integer *, complex *, integer *, 
+	    complex *, integer *), caxpy_(integer *, complex *, complex *, 
+	    integer *, complex *, integer *), ctrmv_(char *, char *, char *, 
+	    integer *, complex *, integer *, complex *, integer *);
+    complex ei;
+    extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, 
+	    integer *, complex *), clacgv_(integer *, complex *, integer *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Quick return if possible */
+
+    /* Parameter adjustments */
+    --tau;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    t_dim1 = *ldt;
+    t_offset = 1 + t_dim1 * 1;
+    t -= t_offset;
+    y_dim1 = *ldy;
+    y_offset = 1 + y_dim1 * 1;
+    y -= y_offset;
+
+    /* Function Body */
+    if (*n <= 1) {
+	return 0;
+    }
+
+    i__1 = *nb;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (i__ > 1) {
+
+/*           Update A(1:n,i) */
+
+/*           Compute i-th column of A - Y * V**H */
+
+	    i__2 = i__ - 1;
+	    clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+	    i__2 = i__ - 1;
+	    q__1.r = -1.f, q__1.i = 0.f;
+	    cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &a[*k 
+		    + i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], &
+		    c__1);
+	    i__2 = i__ - 1;
+	    clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+
+/*           Apply I - V * T**H * V**H to this column (call it b) from the */
+/*           left, using the last column of T as workspace */
+
+/*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows) */
+/*                    ( V2 )             ( b2 ) */
+
+/*           where V1 is unit lower triangular */
+
+/*           w := V1**H * b1 */
+
+	    i__2 = i__ - 1;
+	    ccopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + 
+		    1], &c__1);
+	    i__2 = i__ - 1;
+	    ctrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 + 
+		    a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/*           w := w + V2**H *b2 */
+
+	    i__2 = *n - *k - i__ + 1;
+	    i__3 = i__ - 1;
+	    cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + 
+		    a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
+		    t[*nb * t_dim1 + 1], &c__1);
+
+/*           w := T**H *w */
+
+	    i__2 = i__ - 1;
+	    ctrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[
+		    t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
+
+/*           b2 := b2 - V2*w */
+
+	    i__2 = *n - *k - i__ + 1;
+	    i__3 = i__ - 1;
+	    q__1.r = -1.f, q__1.i = 0.f;
+	    cgemv_("No transpose", &i__2, &i__3, &q__1, &a[*k + i__ + a_dim1],
+		     lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ + 
+		    i__ * a_dim1], &c__1);
+
+/*           b1 := b1 - V1*w */
+
+	    i__2 = i__ - 1;
+	    ctrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
+		    , lda, &t[*nb * t_dim1 + 1], &c__1);
+	    i__2 = i__ - 1;
+	    q__1.r = -1.f, q__1.i = 0.f;
+	    caxpy_(&i__2, &q__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ 
+		    * a_dim1], &c__1);
+
+	    i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
+	    a[i__2].r = ei.r, a[i__2].i = ei.i;
+	}
+
+/*        Generate the elementary reflector H(i) to annihilate */
+/*        A(k+i+1:n,i) */
+
+	i__2 = *k + i__ + i__ * a_dim1;
+	ei.r = a[i__2].r, ei.i = a[i__2].i;
+	i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+	i__3 = *k + i__ + 1;
+	clarfg_(&i__2, &ei, &a[f2cmin(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__])
+		;
+	i__2 = *k + i__ + i__ * a_dim1;
+	a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/*        Compute  Y(1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	cgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1], 
+		lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ * 
+		y_dim1 + 1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = i__ - 1;
+	cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + 
+		a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
+		i__ * t_dim1 + 1], &c__1);
+	i__2 = i__ - 1;
+	q__1.r = -1.f, q__1.i = 0.f;
+	cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &t[i__ * 
+		t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1);
+	cscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
+
+/*        Compute T(1:i,i) */
+
+	i__2 = i__ - 1;
+	i__3 = i__;
+	q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
+	cscal_(&i__2, &q__1, &t[i__ * t_dim1 + 1], &c__1);
+	i__2 = i__ - 1;
+	ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, 
+		&t[i__ * t_dim1 + 1], &c__1)
+		;
+	i__2 = i__ + i__ * t_dim1;
+	i__3 = i__;
+	t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
+
+/* L10: */
+    }
+    i__1 = *k + *nb + *nb * a_dim1;
+    a[i__1].r = ei.r, a[i__1].i = ei.i;
+
+    return 0;
+
+/*     End of CLAHRD */
+
+} /* clahrd_ */
+

lapack-netlib/SRC/DEPRECATED/clatzm.c

@@ -0,0 +1,629 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* > \brief \b CLATZM */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download CLATZM + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clatzm.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clatzm.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clatzm.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) */
+
+/*       CHARACTER          SIDE */
+/*       INTEGER            INCV, LDC, M, N */
+/*       COMPLEX            TAU */
+/*       COMPLEX            C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine CUNMRZ. */
+/* > */
+/* > CLATZM applies a Householder matrix generated by CTZRQF to a matrix. */
+/* > */
+/* > Let P = I - tau*u*u**H,   u = ( 1 ), */
+/* >                               ( v ) */
+/* > where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
+/* > SIDE = 'R'. */
+/* > */
+/* > If SIDE equals 'L', let */
+/* >        C = [ C1 ] 1 */
+/* >            [ C2 ] m-1 */
+/* >              n */
+/* > Then C is overwritten by P*C. */
+/* > */
+/* > If SIDE equals 'R', let */
+/* >        C = [ C1, C2 ] m */
+/* >               1  n-1 */
+/* > Then C is overwritten by C*P. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* >          SIDE is CHARACTER*1 */
+/* >          = 'L': form P * C */
+/* >          = 'R': form C * P */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* >          V is COMPLEX array, dimension */
+/* >                  (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* >                  (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* >          The vector v in the representation of P. V is not used */
+/* >          if TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* >          INCV is INTEGER */
+/* >          The increment between elements of v. INCV <> 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* >          TAU is COMPLEX */
+/* >          The value tau in the representation of P. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C1 */
+/* > \verbatim */
+/* >          C1 is COMPLEX array, dimension */
+/* >                         (LDC,N) if SIDE = 'L' */
+/* >                         (M,1)   if SIDE = 'R' */
+/* >          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
+/* >          if SIDE = 'R'. */
+/* > */
+/* >          On exit, the first row of P*C if SIDE = 'L', or the first */
+/* >          column of C*P if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C2 */
+/* > \verbatim */
+/* >          C2 is COMPLEX array, dimension */
+/* >                         (LDC, N)   if SIDE = 'L' */
+/* >                         (LDC, N-1) if SIDE = 'R' */
+/* >          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
+/* >          m x (n - 1) matrix C2 if SIDE = 'R'. */
+/* > */
+/* >          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
+/* >          if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* >          LDC is INTEGER */
+/* >          The leading dimension of the arrays C1 and C2. */
+/* >          LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX array, dimension */
+/* >                      (N) if SIDE = 'L' */
+/* >                      (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complexOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int clatzm_(char *side, integer *m, integer *n, complex *v, 
+	integer *incv, complex *tau, complex *c1, complex *c2, integer *ldc, 
+	complex *work)
+{
+    /* System generated locals */
+    integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
+    complex q__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, integer *),
+	     cgemv_(char *, integer *, integer *, complex *, complex *, 
+	    integer *, complex *, integer *, complex *, complex *, integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int cgeru_(integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, integer *),
+	     ccopy_(integer *, complex *, integer *, complex *, integer *), 
+	    caxpy_(integer *, complex *, complex *, integer *, complex *, 
+	    integer *), clacgv_(integer *, complex *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    --v;
+    c2_dim1 = *ldc;
+    c2_offset = 1 + c2_dim1 * 1;
+    c2 -= c2_offset;
+    c1_dim1 = *ldc;
+    c1_offset = 1 + c1_dim1 * 1;
+    c1 -= c1_offset;
+    --work;
+
+    /* Function Body */
+    if (f2cmin(*m,*n) == 0 || tau->r == 0.f && tau->i == 0.f) {
+	return 0;
+    }
+
+    if (lsame_(side, "L")) {
+
+/*        w :=  ( C1 + v**H * C2 )**H */
+
+	ccopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
+	clacgv_(n, &work[1], &c__1);
+	i__1 = *m - 1;
+	cgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, &
+		v[1], incv, &c_b1, &work[1], &c__1);
+
+/*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w**H */
+/*        [ C2 ]    [ C2 ]        [ v ] */
+
+	clacgv_(n, &work[1], &c__1);
+	q__1.r = -tau->r, q__1.i = -tau->i;
+	caxpy_(n, &q__1, &work[1], &c__1, &c1[c1_offset], ldc);
+	i__1 = *m - 1;
+	q__1.r = -tau->r, q__1.i = -tau->i;
+	cgeru_(&i__1, n, &q__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], 
+		ldc);
+
+    } else if (lsame_(side, "R")) {
+
+/*        w := C1 + C2 * v */
+
+	ccopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
+	i__1 = *n - 1;
+	cgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1], 
+		incv, &c_b1, &work[1], &c__1);
+
+/*        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**H] */
+
+	q__1.r = -tau->r, q__1.i = -tau->i;
+	caxpy_(m, &q__1, &work[1], &c__1, &c1[c1_offset], &c__1);
+	i__1 = *n - 1;
+	q__1.r = -tau->r, q__1.i = -tau->i;
+	cgerc_(m, &i__1, &q__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], 
+		ldc);
+    }
+
+    return 0;
+
+/*     End of CLATZM */
+
+} /* clatzm_ */
+

lapack-netlib/SRC/DEPRECATED/ctzrqf.c

@@ -0,0 +1,661 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* > \brief \b CTZRQF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download CTZRQF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ctzrqf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ctzrqf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ctzrqf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO ) */
+
+/*       INTEGER            INFO, LDA, M, N */
+/*       COMPLEX            A( LDA, * ), TAU( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine CTZRZF. */
+/* > */
+/* > CTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
+/* > to upper triangular form by means of unitary transformations. */
+/* > */
+/* > The upper trapezoidal matrix A is factored as */
+/* > */
+/* >    A = ( R  0 ) * Z, */
+/* > */
+/* > where Z is an N-by-N unitary matrix and R is an M-by-M upper */
+/* > triangular matrix. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A.  N >= M. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N) */
+/* >          On entry, the leading M-by-N upper trapezoidal part of the */
+/* >          array A must contain the matrix to be factorized. */
+/* >          On exit, the leading M-by-M upper triangular part of A */
+/* >          contains the upper triangular matrix R, and elements M+1 to */
+/* >          N of the first M rows of A, with the array TAU, represent the */
+/* >          unitary matrix Z as a product of M elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is COMPLEX array, dimension (M) */
+/* >          The scalar factors of the elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complexOTHERcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The  factorization is obtained by Householder's method.  The kth */
+/* >  transformation matrix, Z( k ), whose conjugate transpose is used to */
+/* >  introduce zeros into the (m - k + 1)th row of A, is given in the form */
+/* > */
+/* >     Z( k ) = ( I     0   ), */
+/* >              ( 0  T( k ) ) */
+/* > */
+/* >  where */
+/* > */
+/* >     T( k ) = I - tau*u( k )*u( k )**H,   u( k ) = (   1    ), */
+/* >                                                   (   0    ) */
+/* >                                                   ( z( k ) ) */
+/* > */
+/* >  tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* >  tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* >  of X. */
+/* > */
+/* >  The scalar tau is returned in the kth element of TAU and the vector */
+/* >  u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* >  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* >  the upper triangular part of A. */
+/* > */
+/* >  Z is given by */
+/* > */
+/* >     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ctzrqf_(integer *m, integer *n, complex *a, integer *lda,
+	 complex *tau, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    complex q__1, q__2;
+
+    /* Local variables */
+    integer i__, k;
+    extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, integer *);
+    complex alpha;
+    extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+	    , complex *, integer *, complex *, integer *, complex *, complex *
+	    , integer *), ccopy_(integer *, complex *, integer *, 
+	    complex *, integer *), caxpy_(integer *, complex *, complex *, 
+	    integer *, complex *, integer *);
+    integer m1;
+    extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, 
+	    integer *, complex *), clacgv_(integer *, complex *, integer *), 
+	    xerbla_(char *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/* ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --tau;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < *m) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("CTZRQF", &i__1);
+	return 0;
+    }
+
+/*     Perform the factorization. */
+
+    if (*m == 0) {
+	return 0;
+    }
+    if (*m == *n) {
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = i__;
+	    tau[i__2].r = 0.f, tau[i__2].i = 0.f;
+/* L10: */
+	}
+    } else {
+/* Computing MIN */
+	i__1 = *m + 1;
+	m1 = f2cmin(i__1,*n);
+	for (k = *m; k >= 1; --k) {
+
+/*           Use a Householder reflection to zero the kth row of A. */
+/*           First set up the reflection. */
+
+	    i__1 = k + k * a_dim1;
+	    r_cnjg(&q__1, &a[k + k * a_dim1]);
+	    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+	    i__1 = *n - *m;
+	    clacgv_(&i__1, &a[k + m1 * a_dim1], lda);
+	    i__1 = k + k * a_dim1;
+	    alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+	    i__1 = *n - *m + 1;
+	    clarfg_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]);
+	    i__1 = k + k * a_dim1;
+	    a[i__1].r = alpha.r, a[i__1].i = alpha.i;
+	    i__1 = k;
+	    r_cnjg(&q__1, &tau[k]);
+	    tau[i__1].r = q__1.r, tau[i__1].i = q__1.i;
+
+	    i__1 = k;
+	    if ((tau[i__1].r != 0.f || tau[i__1].i != 0.f) && k > 1) {
+
+/*              We now perform the operation  A := A*P( k )**H. */
+
+/*              Use the first ( k - 1 ) elements of TAU to store  a( k ), */
+/*              where  a( k ) consists of the first ( k - 1 ) elements of */
+/*              the  kth column  of  A.  Also  let  B  denote  the  first */
+/*              ( k - 1 ) rows of the last ( n - m ) columns of A. */
+
+		i__1 = k - 1;
+		ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
+
+/*              Form   w = a( k ) + B*z( k )  in TAU. */
+
+		i__1 = k - 1;
+		i__2 = *n - *m;
+		cgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 + 
+			1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], &
+			c__1);
+
+/*              Now form  a( k ) := a( k ) - conjg(tau)*w */
+/*              and       B      := B      - conjg(tau)*w*z( k )**H. */
+
+		i__1 = k - 1;
+		r_cnjg(&q__2, &tau[k]);
+		q__1.r = -q__2.r, q__1.i = -q__2.i;
+		caxpy_(&i__1, &q__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
+			c__1);
+		i__1 = k - 1;
+		i__2 = *n - *m;
+		r_cnjg(&q__2, &tau[k]);
+		q__1.r = -q__2.r, q__1.i = -q__2.i;
+		cgerc_(&i__1, &i__2, &q__1, &tau[1], &c__1, &a[k + m1 * 
+			a_dim1], lda, &a[m1 * a_dim1 + 1], lda);
+	    }
+/* L20: */
+	}
+    }
+
+    return 0;
+
+/*     End of CTZRQF */
+
+} /* ctzrqf_ */
+

lapack-netlib/SRC/DEPRECATED/dgelsx.c

@@ -0,0 +1,877 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static doublereal c_b13 = 0.;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublereal c_b36 = 1.;
+
+/* > \brief <b> DGELSX solves overdetermined or underdetermined systems for GE matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download DGELSX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgelsx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgelsx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgelsx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */
+/*                          WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, LDB, M, N, NRHS, RANK */
+/*       DOUBLE PRECISION   RCOND */
+/*       INTEGER            JPVT( * ) */
+/*       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine DGELSY. */
+/* > */
+/* > DGELSX computes the minimum-norm solution to a real linear least */
+/* > squares problem: */
+/* >     minimize || A * X - B || */
+/* > using a complete orthogonal factorization of A.  A is an M-by-N */
+/* > matrix which may be rank-deficient. */
+/* > */
+/* > Several right hand side vectors b and solution vectors x can be */
+/* > handled in a single call; they are stored as the columns of the */
+/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* > matrix X. */
+/* > */
+/* > The routine first computes a QR factorization with column pivoting: */
+/* >     A * P = Q * [ R11 R12 ] */
+/* >                 [  0  R22 ] */
+/* > with R11 defined as the largest leading submatrix whose estimated */
+/* > condition number is less than 1/RCOND.  The order of R11, RANK, */
+/* > is the effective rank of A. */
+/* > */
+/* > Then, R22 is considered to be negligible, and R12 is annihilated */
+/* > by orthogonal transformations from the right, arriving at the */
+/* > complete orthogonal factorization: */
+/* >    A * P = Q * [ T11 0 ] * Z */
+/* >                [  0  0 ] */
+/* > The minimum-norm solution is then */
+/* >    X = P * Z**T [ inv(T11)*Q1**T*B ] */
+/* >                 [        0         ] */
+/* > where Q1 consists of the first RANK columns of Q. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of */
+/* >          columns of matrices B and X. NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A has been overwritten by details of its */
+/* >          complete orthogonal factorization. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* >          On entry, the M-by-NRHS right hand side matrix B. */
+/* >          On exit, the N-by-NRHS solution matrix X. */
+/* >          If m >= n and RANK = n, the residual sum-of-squares for */
+/* >          the solution in the i-th column is given by the sum of */
+/* >          squares of elements N+1:M in that column. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,M,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JPVT */
+/* > \verbatim */
+/* >          JPVT is INTEGER array, dimension (N) */
+/* >          On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
+/* >          initial column, otherwise it is a free column.  Before */
+/* >          the QR factorization of A, all initial columns are */
+/* >          permuted to the leading positions; only the remaining */
+/* >          free columns are moved as a result of column pivoting */
+/* >          during the factorization. */
+/* >          On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* >          was the k-th column of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RCOND */
+/* > \verbatim */
+/* >          RCOND is DOUBLE PRECISION */
+/* >          RCOND is used to determine the effective rank of A, which */
+/* >          is defined as the order of the largest leading triangular */
+/* >          submatrix R11 in the QR factorization with pivoting of A, */
+/* >          whose estimated condition number < 1/RCOND. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RANK */
+/* > \verbatim */
+/* >          RANK is INTEGER */
+/* >          The effective rank of A, i.e., the order of the submatrix */
+/* >          R11.  This is the same as the order of the submatrix T11 */
+/* >          in the complete orthogonal factorization of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is DOUBLE PRECISION array, dimension */
+/* >                      (f2cmax( f2cmin(M,N)+3*N, 2*f2cmin(M,N)+NRHS )), */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup doubleGEsolve */
+
+/*  ===================================================================== */
+/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs, 
+	doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+	jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *
+	info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+    doublereal d__1;
+
+    /* Local variables */
+    doublereal anrm, bnrm, smin, smax;
+    integer i__, j, k, iascl, ibscl, ismin, ismax;
+    doublereal c1, c2;
+    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, 
+	    integer *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *, integer *), dlaic1_(
+	    integer *, integer *, doublereal *, doublereal *, doublereal *, 
+	    doublereal *, doublereal *, doublereal *, doublereal *);
+    doublereal s1, s2, t1, t2;
+    extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
+	    integer *, doublereal *, integer *), dlabad_(
+	    doublereal *, doublereal *);
+    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *);
+    integer mn;
+    extern /* Subroutine */ int dlascl_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
+	    integer *, integer *), dgeqpf_(integer *, integer *, 
+	    doublereal *, integer *, integer *, doublereal *, doublereal *, 
+	    integer *), dlaset_(char *, integer *, integer *, doublereal *, 
+	    doublereal *, doublereal *, integer *), xerbla_(char *, 
+	    integer *);
+    doublereal bignum;
+    extern /* Subroutine */ int dlatzm_(char *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+	     integer *, doublereal *);
+    doublereal sminpr, smaxpr, smlnum;
+    extern /* Subroutine */ int dtzrqf_(integer *, integer *, doublereal *, 
+	    integer *, doublereal *, integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --jpvt;
+    --work;
+
+    /* Function Body */
+    mn = f2cmin(*m,*n);
+    ismin = mn + 1;
+    ismax = (mn << 1) + 1;
+
+/*     Test the input arguments. */
+
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -5;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = f2cmax(1,*m);
+	if (*ldb < f2cmax(i__1,*n)) {
+	    *info = -7;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGELSX", &i__1);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+/* Computing MIN */
+    i__1 = f2cmin(*m,*n);
+    if (f2cmin(i__1,*nrhs) == 0) {
+	*rank = 0;
+	return 0;
+    }
+
+/*     Get machine parameters */
+
+    smlnum = dlamch_("S") / dlamch_("P");
+    bignum = 1. / smlnum;
+    dlabad_(&smlnum, &bignum);
+
+/*     Scale A, B if f2cmax elements outside range [SMLNUM,BIGNUM] */
+
+    anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
+    iascl = 0;
+    if (anrm > 0. && anrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 1;
+    } else if (anrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 2;
+    } else if (anrm == 0.) {
+
+/*        Matrix all zero. Return zero solution. */
+
+	i__1 = f2cmax(*m,*n);
+	dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
+	*rank = 0;
+	goto L100;
+    }
+
+    bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+    ibscl = 0;
+    if (bnrm > 0. && bnrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+		 info);
+	ibscl = 1;
+    } else if (bnrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+		 info);
+	ibscl = 2;
+    }
+
+/*     Compute QR factorization with column pivoting of A: */
+/*        A * P = Q * R */
+
+    dgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info);
+
+/*     workspace 3*N. Details of Householder rotations stored */
+/*     in WORK(1:MN). */
+
+/*     Determine RANK using incremental condition estimation */
+
+    work[ismin] = 1.;
+    work[ismax] = 1.;
+    smax = (d__1 = a[a_dim1 + 1], abs(d__1));
+    smin = smax;
+    if ((d__1 = a[a_dim1 + 1], abs(d__1)) == 0.) {
+	*rank = 0;
+	i__1 = f2cmax(*m,*n);
+	dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
+	goto L100;
+    } else {
+	*rank = 1;
+    }
+
+L10:
+    if (*rank < mn) {
+	i__ = *rank + 1;
+	dlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+		i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+	dlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+		i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+	if (smaxpr * *rcond <= sminpr) {
+	    i__1 = *rank;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
+		work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
+/* L20: */
+	    }
+	    work[ismin + *rank] = c1;
+	    work[ismax + *rank] = c2;
+	    smin = sminpr;
+	    smax = smaxpr;
+	    ++(*rank);
+	    goto L10;
+	}
+    }
+
+/*     Logically partition R = [ R11 R12 ] */
+/*                             [  0  R22 ] */
+/*     where R11 = R(1:RANK,1:RANK) */
+
+/*     [R11,R12] = [ T11, 0 ] * Y */
+
+    if (*rank < *n) {
+	dtzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
+    }
+
+/*     Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/*     B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) */
+
+    dorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
+	    b[b_offset], ldb, &work[(mn << 1) + 1], info);
+
+/*     workspace NRHS */
+
+/*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+    dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, &
+	    a[a_offset], lda, &b[b_offset], ldb);
+
+    i__1 = *n;
+    for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+	i__2 = *nrhs;
+	for (j = 1; j <= i__2; ++j) {
+	    b[i__ + j * b_dim1] = 0.;
+/* L30: */
+	}
+/* L40: */
+    }
+
+/*     B(1:N,1:NRHS) := Y**T * B(1:N,1:NRHS) */
+
+    if (*rank < *n) {
+	i__1 = *rank;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n - *rank + 1;
+	    dlatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, 
+		    &work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1],
+		     ldb, &work[(mn << 1) + 1]);
+/* L50: */
+	}
+    }
+
+/*     workspace NRHS */
+
+/*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+    i__1 = *nrhs;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    work[(mn << 1) + i__] = 1.;
+/* L60: */
+	}
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    if (work[(mn << 1) + i__] == 1.) {
+		if (jpvt[i__] != i__) {
+		    k = i__;
+		    t1 = b[k + j * b_dim1];
+		    t2 = b[jpvt[k] + j * b_dim1];
+L70:
+		    b[jpvt[k] + j * b_dim1] = t1;
+		    work[(mn << 1) + k] = 0.;
+		    t1 = t2;
+		    k = jpvt[k];
+		    t2 = b[jpvt[k] + j * b_dim1];
+		    if (jpvt[k] != i__) {
+			goto L70;
+		    }
+		    b[i__ + j * b_dim1] = t1;
+		    work[(mn << 1) + k] = 0.;
+		}
+	    }
+/* L80: */
+	}
+/* L90: */
+    }
+
+/*     Undo scaling */
+
+    if (iascl == 1) {
+	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+		 info);
+	dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], 
+		lda, info);
+    } else if (iascl == 2) {
+	dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+		 info);
+	dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], 
+		lda, info);
+    }
+    if (ibscl == 1) {
+	dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+		 info);
+    } else if (ibscl == 2) {
+	dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+		 info);
+    }
+
+L100:
+
+    return 0;
+
+/*     End of DGELSX */
+
+} /* dgelsx_ */
+

lapack-netlib/SRC/DEPRECATED/dgeqpf.c

@@ -0,0 +1,732 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* > \brief \b DGEQPF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download DGEQPF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgeqpf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgeqpf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgeqpf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, M, N */
+/*       INTEGER            JPVT( * ) */
+/*       DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine DGEQP3. */
+/* > */
+/* > DGEQPF computes a QR factorization with column pivoting of a */
+/* > real M-by-N matrix A: A*P = Q*R. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A. M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A. N >= 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, the upper triangle of the array contains the */
+/* >          f2cmin(M,N)-by-N upper triangular matrix R; the elements */
+/* >          below the diagonal, together with the array TAU, */
+/* >          represent the orthogonal matrix Q as a product of */
+/* >          f2cmin(m,n) elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JPVT */
+/* > \verbatim */
+/* >          JPVT is INTEGER array, dimension (N) */
+/* >          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* >          to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* >          the i-th column of A is a free column. */
+/* >          On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* >          was the k-th column of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */
+/* >          The scalar factors of the elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is DOUBLE PRECISION array, dimension (3*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup doubleGEcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The matrix Q is represented as a product of elementary reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(n) */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
+/* > */
+/* >  The matrix P is represented in jpvt as follows: If */
+/* >     jpvt(j) = i */
+/* >  then the jth column of P is the ith canonical unit vector. */
+/* > */
+/* >  Partial column norm updating strategy modified by */
+/* >    Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* >    University of Zagreb, Croatia. */
+/* >  -- April 2011                                                      -- */
+/* >  For more details see LAPACK Working Note 176. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer *
+	lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublereal d__1, d__2;
+
+    /* Local variables */
+    doublereal temp;
+    extern doublereal dnrm2_(integer *, doublereal *, integer *);
+    doublereal temp2;
+    integer i__, j;
+    doublereal tol3z;
+    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *);
+    integer itemp;
+    extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, 
+	    doublereal *, integer *), dgeqr2_(integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *), 
+	    dorm2r_(char *, char *, integer *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *, integer *);
+    integer ma;
+    extern doublereal dlamch_(char *);
+    integer mn;
+    extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+	     integer *, doublereal *);
+    extern integer idamax_(integer *, doublereal *, integer *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    doublereal aii;
+    integer pvt;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --jpvt;
+    --tau;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGEQPF", &i__1);
+	return 0;
+    }
+
+    mn = f2cmin(*m,*n);
+    tol3z = sqrt(dlamch_("Epsilon"));
+
+/*     Move initial columns up front */
+
+    itemp = 1;
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (jpvt[i__] != 0) {
+	    if (i__ != itemp) {
+		dswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
+			 &c__1);
+		jpvt[i__] = jpvt[itemp];
+		jpvt[itemp] = i__;
+	    } else {
+		jpvt[i__] = i__;
+	    }
+	    ++itemp;
+	} else {
+	    jpvt[i__] = i__;
+	}
+/* L10: */
+    }
+    --itemp;
+
+/*     Compute the QR factorization and update remaining columns */
+
+    if (itemp > 0) {
+	ma = f2cmin(itemp,*m);
+	dgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
+	if (ma < *n) {
+	    i__1 = *n - ma;
+	    dorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, &
+		    tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info);
+	}
+    }
+
+    if (itemp < mn) {
+
+/*        Initialize partial column norms. The first n elements of */
+/*        work store the exact column norms. */
+
+	i__1 = *n;
+	for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+	    i__2 = *m - itemp;
+	    work[i__] = dnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
+	    work[*n + i__] = work[i__];
+/* L20: */
+	}
+
+/*        Compute factorization */
+
+	i__1 = mn;
+	for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+
+/*           Determine ith pivot column and swap if necessary */
+
+	    i__2 = *n - i__ + 1;
+	    pvt = i__ - 1 + idamax_(&i__2, &work[i__], &c__1);
+
+	    if (pvt != i__) {
+		dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+			c__1);
+		itemp = jpvt[pvt];
+		jpvt[pvt] = jpvt[i__];
+		jpvt[i__] = itemp;
+		work[pvt] = work[i__];
+		work[*n + pvt] = work[*n + i__];
+	    }
+
+/*           Generate elementary reflector H(i) */
+
+	    if (i__ < *m) {
+		i__2 = *m - i__ + 1;
+		dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ * 
+			a_dim1], &c__1, &tau[i__]);
+	    } else {
+		dlarfg_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], &
+			c__1, &tau[*m]);
+	    }
+
+	    if (i__ < *n) {
+
+/*              Apply H(i) to A(i:m,i+1:n) from the left */
+
+		aii = a[i__ + i__ * a_dim1];
+		a[i__ + i__ * a_dim1] = 1.;
+		i__2 = *m - i__ + 1;
+		i__3 = *n - i__;
+		dlarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+			tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(*
+			n << 1) + 1]);
+		a[i__ + i__ * a_dim1] = aii;
+	    }
+
+/*           Update partial column norms */
+
+	    i__2 = *n;
+	    for (j = i__ + 1; j <= i__2; ++j) {
+		if (work[j] != 0.) {
+
+/*                 NOTE: The following 4 lines follow from the analysis in */
+/*                 Lapack Working Note 176. */
+
+		    temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / work[j];
+/* Computing MAX */
+		    d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
+		    temp = f2cmax(d__1,d__2);
+/* Computing 2nd power */
+		    d__1 = work[j] / work[*n + j];
+		    temp2 = temp * (d__1 * d__1);
+		    if (temp2 <= tol3z) {
+			if (*m - i__ > 0) {
+			    i__3 = *m - i__;
+			    work[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], 
+				    &c__1);
+			    work[*n + j] = work[j];
+			} else {
+			    work[j] = 0.;
+			    work[*n + j] = 0.;
+			}
+		    } else {
+			work[j] *= sqrt(temp);
+		    }
+		}
+/* L30: */
+	    }
+
+/* L40: */
+	}
+    }
+    return 0;
+
+/*     End of DGEQPF */
+
+} /* dgeqpf_ */
+

lapack-netlib/SRC/DEPRECATED/dggsvd.c

@@ -0,0 +1,885 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* > \brief <b> DGGSVD computes the singular value decomposition (SVD) for OTHER matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download DGGSVD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dggsvd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dggsvd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dggsvd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */
+/*                          LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */
+/*                          IWORK, INFO ) */
+
+/*       CHARACTER          JOBQ, JOBU, JOBV */
+/*       INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */
+/*       INTEGER            IWORK( * ) */
+/*       DOUBLE PRECISION   A( LDA, * ), ALPHA( * ), B( LDB, * ), */
+/*      $                   BETA( * ), Q( LDQ, * ), U( LDU, * ), */
+/*      $                   V( LDV, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine DGGSVD3. */
+/* > */
+/* > DGGSVD computes the generalized singular value decomposition (GSVD) */
+/* > of an M-by-N real matrix A and P-by-N real matrix B: */
+/* > */
+/* >       U**T*A*Q = D1*( 0 R ),    V**T*B*Q = D2*( 0 R ) */
+/* > */
+/* > where U, V and Q are orthogonal matrices. */
+/* > Let K+L = the effective numerical rank of the matrix (A**T,B**T)**T, */
+/* > then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */
+/* > D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */
+/* > following structures, respectively: */
+/* > */
+/* > If M-K-L >= 0, */
+/* > */
+/* >                     K  L */
+/* >        D1 =     K ( I  0 ) */
+/* >                 L ( 0  C ) */
+/* >             M-K-L ( 0  0 ) */
+/* > */
+/* >                   K  L */
+/* >        D2 =   L ( 0  S ) */
+/* >             P-L ( 0  0 ) */
+/* > */
+/* >                 N-K-L  K    L */
+/* >   ( 0 R ) = K (  0   R11  R12 ) */
+/* >             L (  0    0   R22 ) */
+/* > */
+/* > where */
+/* > */
+/* >   C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* >   S = diag( BETA(K+1),  ... , BETA(K+L) ), */
+/* >   C**2 + S**2 = I. */
+/* > */
+/* >   R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+/* > */
+/* > If M-K-L < 0, */
+/* > */
+/* >                   K M-K K+L-M */
+/* >        D1 =   K ( I  0    0   ) */
+/* >             M-K ( 0  C    0   ) */
+/* > */
+/* >                     K M-K K+L-M */
+/* >        D2 =   M-K ( 0  S    0  ) */
+/* >             K+L-M ( 0  0    I  ) */
+/* >               P-L ( 0  0    0  ) */
+/* > */
+/* >                    N-K-L  K   M-K  K+L-M */
+/* >   ( 0 R ) =     K ( 0    R11  R12  R13  ) */
+/* >               M-K ( 0     0   R22  R23  ) */
+/* >             K+L-M ( 0     0    0   R33  ) */
+/* > */
+/* > where */
+/* > */
+/* >   C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* >   S = diag( BETA(K+1),  ... , BETA(M) ), */
+/* >   C**2 + S**2 = I. */
+/* > */
+/* >   (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */
+/* >   ( 0  R22 R23 ) */
+/* >   in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+/* > */
+/* > The routine computes C, S, R, and optionally the orthogonal */
+/* > transformation matrices U, V and Q. */
+/* > */
+/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */
+/* > A and B implicitly gives the SVD of A*inv(B): */
+/* >                      A*inv(B) = U*(D1*inv(D2))*V**T. */
+/* > If ( A**T,B**T)**T  has orthonormal columns, then the GSVD of A and B is */
+/* > also equal to the CS decomposition of A and B. Furthermore, the GSVD */
+/* > can be used to derive the solution of the eigenvalue problem: */
+/* >                      A**T*A x = lambda* B**T*B x. */
+/* > In some literature, the GSVD of A and B is presented in the form */
+/* >                  U**T*A*X = ( 0 D1 ),   V**T*B*X = ( 0 D2 ) */
+/* > where U and V are orthogonal and X is nonsingular, D1 and D2 are */
+/* > ``diagonal''.  The former GSVD form can be converted to the latter */
+/* > form by taking the nonsingular matrix X as */
+/* > */
+/* >                      X = Q*( I   0    ) */
+/* >                            ( 0 inv(R) ). */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBU */
+/* > \verbatim */
+/* >          JOBU is CHARACTER*1 */
+/* >          = 'U':  Orthogonal matrix U is computed; */
+/* >          = 'N':  U is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBV */
+/* > \verbatim */
+/* >          JOBV is CHARACTER*1 */
+/* >          = 'V':  Orthogonal matrix V is computed; */
+/* >          = 'N':  V is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBQ */
+/* > \verbatim */
+/* >          JOBQ is CHARACTER*1 */
+/* >          = 'Q':  Orthogonal matrix Q is computed; */
+/* >          = 'N':  Q is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] P */
+/* > \verbatim */
+/* >          P is INTEGER */
+/* >          The number of rows of the matrix B.  P >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* > \endverbatim */
+/* > */
+/* > \param[out] L */
+/* > \verbatim */
+/* >          L is INTEGER */
+/* > */
+/* >          On exit, K and L specify the dimension of the subblocks */
+/* >          described in Purpose. */
+/* >          K + L = effective numerical rank of (A**T,B**T)**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A contains the triangular matrix R, or part of R. */
+/* >          See Purpose for details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is DOUBLE PRECISION array, dimension (LDB,N) */
+/* >          On entry, the P-by-N matrix B. */
+/* >          On exit, B contains the triangular matrix R if M-K-L < 0. */
+/* >          See Purpose for details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,P). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is DOUBLE PRECISION array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] BETA */
+/* > \verbatim */
+/* >          BETA is DOUBLE PRECISION array, dimension (N) */
+/* > */
+/* >          On exit, ALPHA and BETA contain the generalized singular */
+/* >          value pairs of A and B; */
+/* >            ALPHA(1:K) = 1, */
+/* >            BETA(1:K)  = 0, */
+/* >          and if M-K-L >= 0, */
+/* >            ALPHA(K+1:K+L) = C, */
+/* >            BETA(K+1:K+L)  = S, */
+/* >          or if M-K-L < 0, */
+/* >            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */
+/* >            BETA(K+1:M) =S, BETA(M+1:K+L) =1 */
+/* >          and */
+/* >            ALPHA(K+L+1:N) = 0 */
+/* >            BETA(K+L+1:N)  = 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[out] U */
+/* > \verbatim */
+/* >          U is DOUBLE PRECISION array, dimension (LDU,M) */
+/* >          If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */
+/* >          If JOBU = 'N', U is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDU */
+/* > \verbatim */
+/* >          LDU is INTEGER */
+/* >          The leading dimension of the array U. LDU >= f2cmax(1,M) if */
+/* >          JOBU = 'U'; LDU >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] V */
+/* > \verbatim */
+/* >          V is DOUBLE PRECISION array, dimension (LDV,P) */
+/* >          If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */
+/* >          If JOBV = 'N', V is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDV */
+/* > \verbatim */
+/* >          LDV is INTEGER */
+/* >          The leading dimension of the array V. LDV >= f2cmax(1,P) if */
+/* >          JOBV = 'V'; LDV >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Q */
+/* > \verbatim */
+/* >          Q is DOUBLE PRECISION array, dimension (LDQ,N) */
+/* >          If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */
+/* >          If JOBQ = 'N', Q is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDQ */
+/* > \verbatim */
+/* >          LDQ is INTEGER */
+/* >          The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */
+/* >          JOBQ = 'Q'; LDQ >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is DOUBLE PRECISION array, */
+/* >                      dimension (f2cmax(3*N,M,P)+N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* >          On exit, IWORK stores the sorting information. More */
+/* >          precisely, the following loop will sort ALPHA */
+/* >             for I = K+1, f2cmin(M,K+L) */
+/* >                 swap ALPHA(I) and ALPHA(IWORK(I)) */
+/* >             endfor */
+/* >          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* >          > 0:  if INFO = 1, the Jacobi-type procedure failed to */
+/* >                converge.  For further details, see subroutine DTGSJA. */
+/* > \endverbatim */
+
+/* > \par Internal Parameters: */
+/*  ========================= */
+/* > */
+/* > \verbatim */
+/* >  TOLA    DOUBLE PRECISION */
+/* >  TOLB    DOUBLE PRECISION */
+/* >          TOLA and TOLB are the thresholds to determine the effective */
+/* >          rank of (A',B')**T. Generally, they are set to */
+/* >                   TOLA = MAX(M,N)*norm(A)*MAZHEPS, */
+/* >                   TOLB = MAX(P,N)*norm(B)*MAZHEPS. */
+/* >          The size of TOLA and TOLB may affect the size of backward */
+/* >          errors of the decomposition. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup doubleOTHERsing */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* >     Ming Gu and Huan Ren, Computer Science Division, University of */
+/* >     California at Berkeley, USA */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int dggsvd_(char *jobu, char *jobv, char *jobq, integer *m, 
+	integer *n, integer *p, integer *k, integer *l, doublereal *a, 
+	integer *lda, doublereal *b, integer *ldb, doublereal *alpha, 
+	doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer 
+	*ldv, doublereal *q, integer *ldq, doublereal *work, integer *iwork, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, 
+	    u_offset, v_dim1, v_offset, i__1, i__2;
+
+    /* Local variables */
+    integer ibnd;
+    doublereal tola;
+    integer isub;
+    doublereal tolb, unfl, temp, smax;
+    integer ncallmycycle, i__, j;
+    extern logical lsame_(char *, char *);
+    doublereal anorm, bnorm;
+    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
+	    doublereal *, integer *);
+    logical wantq, wantu, wantv;
+    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *);
+    extern /* Subroutine */ int dtgsja_(char *, char *, char *, integer *, 
+	    integer *, integer *, integer *, integer *, doublereal *, integer 
+	    *, doublereal *, integer *, doublereal *, doublereal *, 
+	    doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+	     integer *, doublereal *, integer *, doublereal *, integer *, 
+	    integer *), xerbla_(char *, integer *), dggsvp_(char *, char *, char *, integer *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
+	    integer *, doublereal *, integer *, doublereal *, integer *, 
+	    integer *, doublereal *, doublereal *, integer *);
+    doublereal ulp;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --alpha;
+    --beta;
+    u_dim1 = *ldu;
+    u_offset = 1 + u_dim1 * 1;
+    u -= u_offset;
+    v_dim1 = *ldv;
+    v_offset = 1 + v_dim1 * 1;
+    v -= v_offset;
+    q_dim1 = *ldq;
+    q_offset = 1 + q_dim1 * 1;
+    q -= q_offset;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    wantu = lsame_(jobu, "U");
+    wantv = lsame_(jobv, "V");
+    wantq = lsame_(jobq, "Q");
+
+    *info = 0;
+    if (! (wantu || lsame_(jobu, "N"))) {
+	*info = -1;
+    } else if (! (wantv || lsame_(jobv, "N"))) {
+	*info = -2;
+    } else if (! (wantq || lsame_(jobq, "N"))) {
+	*info = -3;
+    } else if (*m < 0) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -5;
+    } else if (*p < 0) {
+	*info = -6;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -10;
+    } else if (*ldb < f2cmax(1,*p)) {
+	*info = -12;
+    } else if (*ldu < 1 || wantu && *ldu < *m) {
+	*info = -16;
+    } else if (*ldv < 1 || wantv && *ldv < *p) {
+	*info = -18;
+    } else if (*ldq < 1 || wantq && *ldq < *n) {
+	*info = -20;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGGSVD", &i__1);
+	return 0;
+    }
+
+/*     Compute the Frobenius norm of matrices A and B */
+
+    anorm = dlange_("1", m, n, &a[a_offset], lda, &work[1]);
+    bnorm = dlange_("1", p, n, &b[b_offset], ldb, &work[1]);
+
+/*     Get machine precision and set up threshold for determining */
+/*     the effective numerical rank of the matrices A and B. */
+
+    ulp = dlamch_("Precision");
+    unfl = dlamch_("Safe Minimum");
+    tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp;
+    tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp;
+
+/*     Preprocessing */
+
+    dggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, &
+	    tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[
+	    q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], info);
+
+/*     Compute the GSVD of two upper "triangular" matrices */
+
+    dtgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], 
+	    ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+	    v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info);
+
+/*     Sort the singular values and store the pivot indices in IWORK */
+/*     Copy ALPHA to WORK, then sort ALPHA in WORK */
+
+    dcopy_(n, &alpha[1], &c__1, &work[1], &c__1);
+/* Computing MIN */
+    i__1 = *l, i__2 = *m - *k;
+    ibnd = f2cmin(i__1,i__2);
+    i__1 = ibnd;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        Scan for largest ALPHA(K+I) */
+
+	isub = i__;
+	smax = work[*k + i__];
+	i__2 = ibnd;
+	for (j = i__ + 1; j <= i__2; ++j) {
+	    temp = work[*k + j];
+	    if (temp > smax) {
+		isub = j;
+		smax = temp;
+	    }
+/* L10: */
+	}
+	if (isub != i__) {
+	    work[*k + isub] = work[*k + i__];
+	    work[*k + i__] = smax;
+	    iwork[*k + i__] = *k + isub;
+	} else {
+	    iwork[*k + i__] = *k + i__;
+	}
+/* L20: */
+    }
+
+    return 0;
+
+/*     End of DGGSVD */
+
+} /* dggsvd_ */
+

lapack-netlib/SRC/DEPRECATED/dggsvp.c

@@ -0,0 +1,993 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static doublereal c_b12 = 0.;
+static doublereal c_b22 = 1.;
+
+/* > \brief \b DGGSVP */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download DGGSVP + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dggsvp.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dggsvp.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dggsvp.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, */
+/*                          TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, */
+/*                          IWORK, TAU, WORK, INFO ) */
+
+/*       CHARACTER          JOBQ, JOBU, JOBV */
+/*       INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */
+/*       DOUBLE PRECISION   TOLA, TOLB */
+/*       INTEGER            IWORK( * ) */
+/*       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */
+/*      $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine DGGSVP3. */
+/* > */
+/* > DGGSVP computes orthogonal matrices U, V and Q such that */
+/* > */
+/* >                    N-K-L  K    L */
+/* >  U**T*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0; */
+/* >                 L ( 0     0   A23 ) */
+/* >             M-K-L ( 0     0    0  ) */
+/* > */
+/* >                  N-K-L  K    L */
+/* >         =     K ( 0    A12  A13 )  if M-K-L < 0; */
+/* >             M-K ( 0     0   A23 ) */
+/* > */
+/* >                  N-K-L  K    L */
+/* >  V**T*B*Q =   L ( 0     0   B13 ) */
+/* >             P-L ( 0     0    0  ) */
+/* > */
+/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* > otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective */
+/* > numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. */
+/* > */
+/* > This decomposition is the preprocessing step for computing the */
+/* > Generalized Singular Value Decomposition (GSVD), see subroutine */
+/* > DGGSVD. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBU */
+/* > \verbatim */
+/* >          JOBU is CHARACTER*1 */
+/* >          = 'U':  Orthogonal matrix U is computed; */
+/* >          = 'N':  U is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBV */
+/* > \verbatim */
+/* >          JOBV is CHARACTER*1 */
+/* >          = 'V':  Orthogonal matrix V is computed; */
+/* >          = 'N':  V is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBQ */
+/* > \verbatim */
+/* >          JOBQ is CHARACTER*1 */
+/* >          = 'Q':  Orthogonal matrix Q is computed; */
+/* >          = 'N':  Q is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] P */
+/* > \verbatim */
+/* >          P is INTEGER */
+/* >          The number of rows of the matrix B.  P >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A contains the triangular (or trapezoidal) matrix */
+/* >          described in the Purpose section. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is DOUBLE PRECISION array, dimension (LDB,N) */
+/* >          On entry, the P-by-N matrix B. */
+/* >          On exit, B contains the triangular matrix described in */
+/* >          the Purpose section. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,P). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TOLA */
+/* > \verbatim */
+/* >          TOLA is DOUBLE PRECISION */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TOLB */
+/* > \verbatim */
+/* >          TOLB is DOUBLE PRECISION */
+/* > */
+/* >          TOLA and TOLB are the thresholds to determine the effective */
+/* >          numerical rank of matrix B and a subblock of A. Generally, */
+/* >          they are set to */
+/* >             TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* >             TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+/* >          The size of TOLA and TOLB may affect the size of backward */
+/* >          errors of the decomposition. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* > \endverbatim */
+/* > */
+/* > \param[out] L */
+/* > \verbatim */
+/* >          L is INTEGER */
+/* > */
+/* >          On exit, K and L specify the dimension of the subblocks */
+/* >          described in Purpose section. */
+/* >          K + L = effective numerical rank of (A**T,B**T)**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] U */
+/* > \verbatim */
+/* >          U is DOUBLE PRECISION array, dimension (LDU,M) */
+/* >          If JOBU = 'U', U contains the orthogonal matrix U. */
+/* >          If JOBU = 'N', U is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDU */
+/* > \verbatim */
+/* >          LDU is INTEGER */
+/* >          The leading dimension of the array U. LDU >= f2cmax(1,M) if */
+/* >          JOBU = 'U'; LDU >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] V */
+/* > \verbatim */
+/* >          V is DOUBLE PRECISION array, dimension (LDV,P) */
+/* >          If JOBV = 'V', V contains the orthogonal matrix V. */
+/* >          If JOBV = 'N', V is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDV */
+/* > \verbatim */
+/* >          LDV is INTEGER */
+/* >          The leading dimension of the array V. LDV >= f2cmax(1,P) if */
+/* >          JOBV = 'V'; LDV >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Q */
+/* > \verbatim */
+/* >          Q is DOUBLE PRECISION array, dimension (LDQ,N) */
+/* >          If JOBQ = 'Q', Q contains the orthogonal matrix Q. */
+/* >          If JOBQ = 'N', Q is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDQ */
+/* > \verbatim */
+/* >          LDQ is INTEGER */
+/* >          The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */
+/* >          JOBQ = 'Q'; LDQ >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is DOUBLE PRECISION array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is DOUBLE PRECISION array, dimension (f2cmax(3*N,M,P)) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup doubleOTHERcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* >  The subroutine uses LAPACK subroutine DGEQPF for the QR factorization */
+/* >  with column pivoting to detect the effective numerical rank of the */
+/* >  a matrix. It may be replaced by a better rank determination strategy. */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int dggsvp_(char *jobu, char *jobv, char *jobq, integer *m, 
+	integer *p, integer *n, doublereal *a, integer *lda, doublereal *b, 
+	integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer 
+	*l, doublereal *u, integer *ldu, doublereal *v, integer *ldv, 
+	doublereal *q, integer *ldq, integer *iwork, doublereal *tau, 
+	doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, 
+	    u_offset, v_dim1, v_offset, i__1, i__2, i__3;
+    doublereal d__1;
+
+    /* Local variables */
+    integer i__, j;
+    extern logical lsame_(char *, char *);
+    logical wantq, wantu, wantv;
+    extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *, 
+	    integer *, doublereal *, doublereal *, integer *), dgerq2_(
+	    integer *, integer *, doublereal *, integer *, doublereal *, 
+	    doublereal *, integer *), dorg2r_(integer *, integer *, integer *,
+	     doublereal *, integer *, doublereal *, doublereal *, integer *), 
+	    dorm2r_(char *, char *, integer *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *, integer *), dormr2_(char *, char *, 
+	    integer *, integer *, integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *, integer *, doublereal *, integer *), dgeqpf_(integer *, integer *, doublereal *, 
+	    integer *, integer *, doublereal *, doublereal *, integer *), 
+	    dlacpy_(char *, integer *, integer *, doublereal *, integer *, 
+	    doublereal *, integer *), dlaset_(char *, integer *, 
+	    integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *), dlapmt_(logical *, 
+	    integer *, integer *, doublereal *, integer *, integer *);
+    logical forwrd;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    u_dim1 = *ldu;
+    u_offset = 1 + u_dim1 * 1;
+    u -= u_offset;
+    v_dim1 = *ldv;
+    v_offset = 1 + v_dim1 * 1;
+    v -= v_offset;
+    q_dim1 = *ldq;
+    q_offset = 1 + q_dim1 * 1;
+    q -= q_offset;
+    --iwork;
+    --tau;
+    --work;
+
+    /* Function Body */
+    wantu = lsame_(jobu, "U");
+    wantv = lsame_(jobv, "V");
+    wantq = lsame_(jobq, "Q");
+    forwrd = TRUE_;
+
+    *info = 0;
+    if (! (wantu || lsame_(jobu, "N"))) {
+	*info = -1;
+    } else if (! (wantv || lsame_(jobv, "N"))) {
+	*info = -2;
+    } else if (! (wantq || lsame_(jobq, "N"))) {
+	*info = -3;
+    } else if (*m < 0) {
+	*info = -4;
+    } else if (*p < 0) {
+	*info = -5;
+    } else if (*n < 0) {
+	*info = -6;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -8;
+    } else if (*ldb < f2cmax(1,*p)) {
+	*info = -10;
+    } else if (*ldu < 1 || wantu && *ldu < *m) {
+	*info = -16;
+    } else if (*ldv < 1 || wantv && *ldv < *p) {
+	*info = -18;
+    } else if (*ldq < 1 || wantq && *ldq < *n) {
+	*info = -20;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGGSVP", &i__1);
+	return 0;
+    }
+
+/*     QR with column pivoting of B: B*P = V*( S11 S12 ) */
+/*                                           (  0   0  ) */
+
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	iwork[i__] = 0;
+/* L10: */
+    }
+    dgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
+
+/*     Update A := A*P */
+
+    dlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
+
+/*     Determine the effective rank of matrix B. */
+
+    *l = 0;
+    i__1 = f2cmin(*p,*n);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) > *tolb) {
+	    ++(*l);
+	}
+/* L20: */
+    }
+
+    if (wantv) {
+
+/*        Copy the details of V, and form V. */
+
+	dlaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv);
+	if (*p > 1) {
+	    i__1 = *p - 1;
+	    dlacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], 
+		    ldv);
+	}
+	i__1 = f2cmin(*p,*n);
+	dorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
+    }
+
+/*     Clean up B */
+
+    i__1 = *l - 1;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *l;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    b[i__ + j * b_dim1] = 0.;
+/* L30: */
+	}
+/* L40: */
+    }
+    if (*p > *l) {
+	i__1 = *p - *l;
+	dlaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb);
+    }
+
+    if (wantq) {
+
+/*        Set Q = I and Update Q := Q*P */
+
+	dlaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq);
+	dlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
+    }
+
+    if (*p >= *l && *n != *l) {
+
+/*        RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
+
+	dgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
+
+/*        Update A := A*Z**T */
+
+	dormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[
+		a_offset], lda, &work[1], info);
+
+	if (wantq) {
+
+/*           Update Q := Q*Z**T */
+
+	    dormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1],
+		     &q[q_offset], ldq, &work[1], info);
+	}
+
+/*        Clean up B */
+
+	i__1 = *n - *l;
+	dlaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb);
+	i__1 = *n;
+	for (j = *n - *l + 1; j <= i__1; ++j) {
+	    i__2 = *l;
+	    for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
+		b[i__ + j * b_dim1] = 0.;
+/* L50: */
+	    }
+/* L60: */
+	}
+
+    }
+
+/*     Let              N-L     L */
+/*                A = ( A11    A12 ) M, */
+
+/*     then the following does the complete QR decomposition of A11: */
+
+/*              A11 = U*(  0  T12 )*P1**T */
+/*                      (  0   0  ) */
+
+    i__1 = *n - *l;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	iwork[i__] = 0;
+/* L70: */
+    }
+    i__1 = *n - *l;
+    dgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info);
+
+/*     Determine the effective rank of A11 */
+
+    *k = 0;
+/* Computing MIN */
+    i__2 = *m, i__3 = *n - *l;
+    i__1 = f2cmin(i__2,i__3);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) > *tola) {
+	    ++(*k);
+	}
+/* L80: */
+    }
+
+/*     Update A12 := U**T*A12, where A12 = A( 1:M, N-L+1:N ) */
+
+/* Computing MIN */
+    i__2 = *m, i__3 = *n - *l;
+    i__1 = f2cmin(i__2,i__3);
+    dorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[(
+	    *n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
+
+    if (wantu) {
+
+/*        Copy the details of U, and form U */
+
+	dlaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu);
+	if (*m > 1) {
+	    i__1 = *m - 1;
+	    i__2 = *n - *l;
+	    dlacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2]
+		    , ldu);
+	}
+/* Computing MIN */
+	i__2 = *m, i__3 = *n - *l;
+	i__1 = f2cmin(i__2,i__3);
+	dorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
+    }
+
+    if (wantq) {
+
+/*        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1 */
+
+	i__1 = *n - *l;
+	dlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
+    }
+
+/*     Clean up A: set the strictly lower triangular part of */
+/*     A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
+
+    i__1 = *k - 1;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *k;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    a[i__ + j * a_dim1] = 0.;
+/* L90: */
+	}
+/* L100: */
+    }
+    if (*m > *k) {
+	i__1 = *m - *k;
+	i__2 = *n - *l;
+	dlaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1], 
+		lda);
+    }
+
+    if (*n - *l > *k) {
+
+/*        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
+
+	i__1 = *n - *l;
+	dgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
+
+	if (wantq) {
+
+/*           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**T */
+
+	    i__1 = *n - *l;
+	    dormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, &
+		    tau[1], &q[q_offset], ldq, &work[1], info);
+	}
+
+/*        Clean up A */
+
+	i__1 = *n - *l - *k;
+	dlaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda);
+	i__1 = *n - *l;
+	for (j = *n - *l - *k + 1; j <= i__1; ++j) {
+	    i__2 = *k;
+	    for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] = 0.;
+/* L110: */
+	    }
+/* L120: */
+	}
+
+    }
+
+    if (*m > *k) {
+
+/*        QR factorization of A( K+1:M,N-L+1:N ) */
+
+	i__1 = *m - *k;
+	dgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &
+		work[1], info);
+
+	if (wantu) {
+
+/*           Update U(:,K+1:M) := U(:,K+1:M)*U1 */
+
+	    i__1 = *m - *k;
+/* Computing MIN */
+	    i__3 = *m - *k;
+	    i__2 = f2cmin(i__3,*l);
+	    dorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n 
+		    - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + 
+		    1], ldu, &work[1], info);
+	}
+
+/*        Clean up */
+
+	i__1 = *n;
+	for (j = *n - *l + 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] = 0.;
+/* L130: */
+	    }
+/* L140: */
+	}
+
+    }
+
+    return 0;
+
+/*     End of DGGSVP */
+
+} /* dggsvp_ */
+

lapack-netlib/SRC/DEPRECATED/dlahrd.c

@@ -0,0 +1,721 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1.;
+static doublereal c_b5 = 1.;
+static integer c__1 = 1;
+static doublereal c_b38 = 0.;
+
+/* > \brief \b DLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below th
+e k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformati
+on to the unreduced part of A. */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download DLAHRD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlahrd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlahrd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlahrd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */
+
+/*       INTEGER            K, LDA, LDT, LDY, N, NB */
+/*       DOUBLE PRECISION   A( LDA, * ), T( LDT, NB ), TAU( NB ), */
+/*      $                   Y( LDY, NB ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine DLAHR2. */
+/* > */
+/* > DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */
+/* > matrix A so that elements below the k-th subdiagonal are zero. The */
+/* > reduction is performed by an orthogonal similarity transformation */
+/* > Q**T * A * Q. The routine returns the matrices V and T which determine */
+/* > Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The offset for the reduction. Elements below the k-th */
+/* >          subdiagonal in the first NB columns are reduced to zero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NB */
+/* > \verbatim */
+/* >          NB is INTEGER */
+/* >          The number of columns to be reduced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N-K+1) */
+/* >          On entry, the n-by-(n-k+1) general matrix A. */
+/* >          On exit, the elements on and above the k-th subdiagonal in */
+/* >          the first NB columns are overwritten with the corresponding */
+/* >          elements of the reduced matrix; the elements below the k-th */
+/* >          subdiagonal, with the array TAU, represent the matrix Q as a */
+/* >          product of elementary reflectors. The other columns of A are */
+/* >          unchanged. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is DOUBLE PRECISION array, dimension (NB) */
+/* >          The scalar factors of the elementary reflectors. See Further */
+/* >          Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] T */
+/* > \verbatim */
+/* >          T is DOUBLE PRECISION array, dimension (LDT,NB) */
+/* >          The upper triangular matrix T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDT */
+/* > \verbatim */
+/* >          LDT is INTEGER */
+/* >          The leading dimension of the array T.  LDT >= NB. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Y */
+/* > \verbatim */
+/* >          Y is DOUBLE PRECISION array, dimension (LDY,NB) */
+/* >          The n-by-nb matrix Y. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDY */
+/* > \verbatim */
+/* >          LDY is INTEGER */
+/* >          The leading dimension of the array Y. LDY >= N. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup doubleOTHERauxiliary */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The matrix Q is represented as a product of nb elementary reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(nb). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* >  A(i+k+1:n,i), and tau in TAU(i). */
+/* > */
+/* >  The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* >  V which is needed, with T and Y, to apply the transformation to the */
+/* >  unreduced part of the matrix, using an update of the form: */
+/* >  A := (I - V*T*V**T) * (A - Y*V**T). */
+/* > */
+/* >  The contents of A on exit are illustrated by the following example */
+/* >  with n = 7, k = 3 and nb = 2: */
+/* > */
+/* >     ( a   h   a   a   a ) */
+/* >     ( a   h   a   a   a ) */
+/* >     ( a   h   a   a   a ) */
+/* >     ( h   h   a   a   a ) */
+/* >     ( v1  h   a   a   a ) */
+/* >     ( v1  v2  a   a   a ) */
+/* >     ( v1  v2  a   a   a ) */
+/* > */
+/* >  where a denotes an element of the original matrix A, h denotes a */
+/* >  modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* >  element of the vector defining H(i). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, doublereal *
+	a, integer *lda, doublereal *tau, doublereal *t, integer *ldt, 
+	doublereal *y, integer *ldy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, 
+	    i__3;
+    doublereal d__1;
+
+    /* Local variables */
+    integer i__;
+    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
+	    integer *), dgemv_(char *, integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    doublereal *, integer *), dcopy_(integer *, doublereal *, 
+	    integer *, doublereal *, integer *), daxpy_(integer *, doublereal 
+	    *, doublereal *, integer *, doublereal *, integer *), dtrmv_(char 
+	    *, char *, char *, integer *, doublereal *, integer *, doublereal 
+	    *, integer *);
+    doublereal ei;
+    extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+	     integer *, doublereal *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Quick return if possible */
+
+    /* Parameter adjustments */
+    --tau;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    t_dim1 = *ldt;
+    t_offset = 1 + t_dim1 * 1;
+    t -= t_offset;
+    y_dim1 = *ldy;
+    y_offset = 1 + y_dim1 * 1;
+    y -= y_offset;
+
+    /* Function Body */
+    if (*n <= 1) {
+	return 0;
+    }
+
+    i__1 = *nb;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (i__ > 1) {
+
+/*           Update A(1:n,i) */
+
+/*           Compute i-th column of A - Y * V**T */
+
+	    i__2 = i__ - 1;
+	    dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k 
+		    + i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], &
+		    c__1);
+
+/*           Apply I - V * T**T * V**T to this column (call it b) from the */
+/*           left, using the last column of T as workspace */
+
+/*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows) */
+/*                    ( V2 )             ( b2 ) */
+
+/*           where V1 is unit lower triangular */
+
+/*           w := V1**T * b1 */
+
+	    i__2 = i__ - 1;
+	    dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + 
+		    1], &c__1);
+	    i__2 = i__ - 1;
+	    dtrmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1], 
+		    lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/*           w := w + V2**T *b2 */
+
+	    i__2 = *n - *k - i__ + 1;
+	    i__3 = i__ - 1;
+	    dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], 
+		    lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * 
+		    t_dim1 + 1], &c__1);
+
+/*           w := T**T *w */
+
+	    i__2 = i__ - 1;
+	    dtrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt,
+		     &t[*nb * t_dim1 + 1], &c__1);
+
+/*           b2 := b2 - V2*w */
+
+	    i__2 = *n - *k - i__ + 1;
+	    i__3 = i__ - 1;
+	    dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
+		     lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + 
+		    i__ * a_dim1], &c__1);
+
+/*           b1 := b1 - V1*w */
+
+	    i__2 = i__ - 1;
+	    dtrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
+		    , lda, &t[*nb * t_dim1 + 1], &c__1);
+	    i__2 = i__ - 1;
+	    daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ 
+		    * a_dim1], &c__1);
+
+	    a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
+	}
+
+/*        Generate the elementary reflector H(i) to annihilate */
+/*        A(k+i+1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+	i__3 = *k + i__ + 1;
+	dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[f2cmin(i__3,*n) + i__ * 
+		a_dim1], &c__1, &tau[i__]);
+	ei = a[*k + i__ + i__ * a_dim1];
+	a[*k + i__ + i__ * a_dim1] = 1.;
+
+/*        Compute  Y(1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	dgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1], 
+		lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ * 
+		y_dim1 + 1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = i__ - 1;
+	dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
+		a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + 
+		1], &c__1);
+	i__2 = i__ - 1;
+	dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ * 
+		t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1);
+	dscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
+
+/*        Compute T(1:i,i) */
+
+	i__2 = i__ - 1;
+	d__1 = -tau[i__];
+	dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
+	i__2 = i__ - 1;
+	dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, 
+		&t[i__ * t_dim1 + 1], &c__1)
+		;
+	t[i__ + i__ * t_dim1] = tau[i__];
+
+/* L10: */
+    }
+    a[*k + *nb + *nb * a_dim1] = ei;
+
+    return 0;
+
+/*     End of DLAHRD */
+
+} /* dlahrd_ */
+

lapack-netlib/SRC/DEPRECATED/dlatzm.c

@@ -0,0 +1,626 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b5 = 1.;
+
+/* > \brief \b DLATZM */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download DLATZM + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlatzm.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlatzm.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlatzm.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) */
+
+/*       CHARACTER          SIDE */
+/*       INTEGER            INCV, LDC, M, N */
+/*       DOUBLE PRECISION   TAU */
+/*       DOUBLE PRECISION   C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine DORMRZ. */
+/* > */
+/* > DLATZM applies a Householder matrix generated by DTZRQF to a matrix. */
+/* > */
+/* > Let P = I - tau*u*u**T,   u = ( 1 ), */
+/* >                               ( v ) */
+/* > where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
+/* > SIDE = 'R'. */
+/* > */
+/* > If SIDE equals 'L', let */
+/* >        C = [ C1 ] 1 */
+/* >            [ C2 ] m-1 */
+/* >              n */
+/* > Then C is overwritten by P*C. */
+/* > */
+/* > If SIDE equals 'R', let */
+/* >        C = [ C1, C2 ] m */
+/* >               1  n-1 */
+/* > Then C is overwritten by C*P. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* >          SIDE is CHARACTER*1 */
+/* >          = 'L': form P * C */
+/* >          = 'R': form C * P */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* >          V is DOUBLE PRECISION array, dimension */
+/* >                  (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* >                  (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* >          The vector v in the representation of P. V is not used */
+/* >          if TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* >          INCV is INTEGER */
+/* >          The increment between elements of v. INCV <> 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* >          TAU is DOUBLE PRECISION */
+/* >          The value tau in the representation of P. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C1 */
+/* > \verbatim */
+/* >          C1 is DOUBLE PRECISION array, dimension */
+/* >                         (LDC,N) if SIDE = 'L' */
+/* >                         (M,1)   if SIDE = 'R' */
+/* >          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
+/* >          if SIDE = 'R'. */
+/* > */
+/* >          On exit, the first row of P*C if SIDE = 'L', or the first */
+/* >          column of C*P if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C2 */
+/* > \verbatim */
+/* >          C2 is DOUBLE PRECISION array, dimension */
+/* >                         (LDC, N)   if SIDE = 'L' */
+/* >                         (LDC, N-1) if SIDE = 'R' */
+/* >          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
+/* >          m x (n - 1) matrix C2 if SIDE = 'R'. */
+/* > */
+/* >          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
+/* >          if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* >          LDC is INTEGER */
+/* >          The leading dimension of the arrays C1 and C2. LDC >= (1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is DOUBLE PRECISION array, dimension */
+/* >                      (N) if SIDE = 'L' */
+/* >                      (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup doubleOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlatzm_(char *side, integer *m, integer *n, doublereal *
+	v, integer *incv, doublereal *tau, doublereal *c1, doublereal *c2, 
+	integer *ldc, doublereal *work)
+{
+    /* System generated locals */
+    integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
+    doublereal d__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *, integer *), dcopy_(integer *, 
+	    doublereal *, integer *, doublereal *, integer *), daxpy_(integer 
+	    *, doublereal *, doublereal *, integer *, doublereal *, integer *)
+	    ;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    --v;
+    c2_dim1 = *ldc;
+    c2_offset = 1 + c2_dim1 * 1;
+    c2 -= c2_offset;
+    c1_dim1 = *ldc;
+    c1_offset = 1 + c1_dim1 * 1;
+    c1 -= c1_offset;
+    --work;
+
+    /* Function Body */
+    if (f2cmin(*m,*n) == 0 || *tau == 0.) {
+	return 0;
+    }
+
+    if (lsame_(side, "L")) {
+
+/*        w :=  (C1 + v**T * C2)**T */
+
+	dcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
+	i__1 = *m - 1;
+	dgemv_("Transpose", &i__1, n, &c_b5, &c2[c2_offset], ldc, &v[1], incv,
+		 &c_b5, &work[1], &c__1);
+
+/*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w**T */
+/*        [ C2 ]    [ C2 ]        [ v ] */
+
+	d__1 = -(*tau);
+	daxpy_(n, &d__1, &work[1], &c__1, &c1[c1_offset], ldc);
+	i__1 = *m - 1;
+	d__1 = -(*tau);
+	dger_(&i__1, n, &d__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], 
+		ldc);
+
+    } else if (lsame_(side, "R")) {
+
+/*        w := C1 + C2 * v */
+
+	dcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
+	i__1 = *n - 1;
+	dgemv_("No transpose", m, &i__1, &c_b5, &c2[c2_offset], ldc, &v[1], 
+		incv, &c_b5, &work[1], &c__1);
+
+/*        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**T] */
+
+	d__1 = -(*tau);
+	daxpy_(m, &d__1, &work[1], &c__1, &c1[c1_offset], &c__1);
+	i__1 = *n - 1;
+	d__1 = -(*tau);
+	dger_(m, &i__1, &d__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], 
+		ldc);
+    }
+
+    return 0;
+
+/*     End of DLATZM */
+
+} /* dlatzm_ */
+

lapack-netlib/SRC/DEPRECATED/dtzrqf.c

@@ -0,0 +1,646 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = 1.;
+
+/* > \brief \b DTZRQF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download DTZRQF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtzrqf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtzrqf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtzrqf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO ) */
+
+/*       INTEGER            INFO, LDA, M, N */
+/*       DOUBLE PRECISION   A( LDA, * ), TAU( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine DTZRZF. */
+/* > */
+/* > DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
+/* > to upper triangular form by means of orthogonal transformations. */
+/* > */
+/* > The upper trapezoidal matrix A is factored as */
+/* > */
+/* >    A = ( R  0 ) * Z, */
+/* > */
+/* > where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
+/* > triangular matrix. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A.  N >= M. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N) */
+/* >          On entry, the leading M-by-N upper trapezoidal part of the */
+/* >          array A must contain the matrix to be factorized. */
+/* >          On exit, the leading M-by-M upper triangular part of A */
+/* >          contains the upper triangular matrix R, and elements M+1 to */
+/* >          N of the first M rows of A, with the array TAU, represent the */
+/* >          orthogonal matrix Z as a product of M elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is DOUBLE PRECISION array, dimension (M) */
+/* >          The scalar factors of the elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup doubleOTHERcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The factorization is obtained by Householder's method.  The kth */
+/* >  transformation matrix, Z( k ), which is used to introduce zeros into */
+/* >  the ( m - k + 1 )th row of A, is given in the form */
+/* > */
+/* >     Z( k ) = ( I     0   ), */
+/* >              ( 0  T( k ) ) */
+/* > */
+/* >  where */
+/* > */
+/* >     T( k ) = I - tau*u( k )*u( k )**T,   u( k ) = (   1    ), */
+/* >                                                   (   0    ) */
+/* >                                                   ( z( k ) ) */
+/* > */
+/* >  tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* >  tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* >  of X. */
+/* > */
+/* >  The scalar tau is returned in the kth element of TAU and the vector */
+/* >  u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* >  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* >  the upper triangular part of A. */
+/* > */
+/* >  Z is given by */
+/* > */
+/* >     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer *
+	lda, doublereal *tau, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    doublereal d__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *);
+    integer i__, k;
+    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *, integer *), dcopy_(integer *, 
+	    doublereal *, integer *, doublereal *, integer *), daxpy_(integer 
+	    *, doublereal *, doublereal *, integer *, doublereal *, integer *)
+	    ;
+    integer m1;
+    extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+	     integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --tau;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < *m) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DTZRQF", &i__1);
+	return 0;
+    }
+
+/*     Perform the factorization. */
+
+    if (*m == 0) {
+	return 0;
+    }
+    if (*m == *n) {
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    tau[i__] = 0.;
+/* L10: */
+	}
+    } else {
+/* Computing MIN */
+	i__1 = *m + 1;
+	m1 = f2cmin(i__1,*n);
+	for (k = *m; k >= 1; --k) {
+
+/*           Use a Householder reflection to zero the kth row of A. */
+/*           First set up the reflection. */
+
+	    i__1 = *n - *m + 1;
+	    dlarfg_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[
+		    k]);
+
+	    if (tau[k] != 0. && k > 1) {
+
+/*              We now perform the operation  A := A*P( k ). */
+
+/*              Use the first ( k - 1 ) elements of TAU to store  a( k ), */
+/*              where  a( k ) consists of the first ( k - 1 ) elements of */
+/*              the  kth column  of  A.  Also  let  B  denote  the  first */
+/*              ( k - 1 ) rows of the last ( n - m ) columns of A. */
+
+		i__1 = k - 1;
+		dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
+
+/*              Form   w = a( k ) + B*z( k )  in TAU. */
+
+		i__1 = k - 1;
+		i__2 = *n - *m;
+		dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 + 
+			1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], &
+			c__1);
+
+/*              Now form  a( k ) := a( k ) - tau*w */
+/*              and       B      := B      - tau*w*z( k )**T. */
+
+		i__1 = k - 1;
+		d__1 = -tau[k];
+		daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
+			c__1);
+		i__1 = k - 1;
+		i__2 = *n - *m;
+		d__1 = -tau[k];
+		dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1]
+			, lda, &a[m1 * a_dim1 + 1], lda);
+	    }
+/* L20: */
+	}
+    }
+
+    return 0;
+
+/*     End of DTZRQF */
+
+} /* dtzrqf_ */
+

lapack-netlib/SRC/DEPRECATED/sgelsx.c

@@ -0,0 +1,870 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static real c_b13 = 0.f;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static real c_b36 = 1.f;
+
+/* > \brief <b> SGELSX solves overdetermined or underdetermined systems for GE matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SGELSX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgelsx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgelsx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgelsx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */
+/*                          WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, LDB, M, N, NRHS, RANK */
+/*       REAL               RCOND */
+/*       INTEGER            JPVT( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine SGELSY. */
+/* > */
+/* > SGELSX computes the minimum-norm solution to a real linear least */
+/* > squares problem: */
+/* >     minimize || A * X - B || */
+/* > using a complete orthogonal factorization of A.  A is an M-by-N */
+/* > matrix which may be rank-deficient. */
+/* > */
+/* > Several right hand side vectors b and solution vectors x can be */
+/* > handled in a single call; they are stored as the columns of the */
+/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* > matrix X. */
+/* > */
+/* > The routine first computes a QR factorization with column pivoting: */
+/* >     A * P = Q * [ R11 R12 ] */
+/* >                 [  0  R22 ] */
+/* > with R11 defined as the largest leading submatrix whose estimated */
+/* > condition number is less than 1/RCOND.  The order of R11, RANK, */
+/* > is the effective rank of A. */
+/* > */
+/* > Then, R22 is considered to be negligible, and R12 is annihilated */
+/* > by orthogonal transformations from the right, arriving at the */
+/* > complete orthogonal factorization: */
+/* >    A * P = Q * [ T11 0 ] * Z */
+/* >                [  0  0 ] */
+/* > The minimum-norm solution is then */
+/* >    X = P * Z**T [ inv(T11)*Q1**T*B ] */
+/* >                 [        0         ] */
+/* > where Q1 consists of the first RANK columns of Q. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of */
+/* >          columns of matrices B and X. NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A has been overwritten by details of its */
+/* >          complete orthogonal factorization. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the M-by-NRHS right hand side matrix B. */
+/* >          On exit, the N-by-NRHS solution matrix X. */
+/* >          If m >= n and RANK = n, the residual sum-of-squares for */
+/* >          the solution in the i-th column is given by the sum of */
+/* >          squares of elements N+1:M in that column. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,M,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JPVT */
+/* > \verbatim */
+/* >          JPVT is INTEGER array, dimension (N) */
+/* >          On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
+/* >          initial column, otherwise it is a free column.  Before */
+/* >          the QR factorization of A, all initial columns are */
+/* >          permuted to the leading positions; only the remaining */
+/* >          free columns are moved as a result of column pivoting */
+/* >          during the factorization. */
+/* >          On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* >          was the k-th column of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RCOND */
+/* > \verbatim */
+/* >          RCOND is REAL */
+/* >          RCOND is used to determine the effective rank of A, which */
+/* >          is defined as the order of the largest leading triangular */
+/* >          submatrix R11 in the QR factorization with pivoting of A, */
+/* >          whose estimated condition number < 1/RCOND. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RANK */
+/* > \verbatim */
+/* >          RANK is INTEGER */
+/* >          The effective rank of A, i.e., the order of the submatrix */
+/* >          R11.  This is the same as the order of the submatrix T11 */
+/* >          in the complete orthogonal factorization of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension */
+/* >                      (f2cmax( f2cmin(M,N)+3*N, 2*f2cmin(M,N)+NRHS )), */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realGEsolve */
+
+/*  ===================================================================== */
+/* Subroutine */ int sgelsx_(integer *m, integer *n, integer *nrhs, real *a, 
+	integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond, 
+	integer *rank, real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    real anrm, bnrm, smin, smax;
+    integer i__, j, k, iascl, ibscl, ismin, ismax;
+    real c1, c2, s1, s2, t1, t2;
+    extern /* Subroutine */ int strsm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    ), slaic1_(integer *, integer *, 
+	    real *, real *, real *, real *, real *, real *, real *), sorm2r_(
+	    char *, char *, integer *, integer *, integer *, real *, integer *
+	    , real *, real *, integer *, real *, integer *), 
+	    slabad_(real *, real *);
+    integer mn;
+    extern real slamch_(char *), slange_(char *, integer *, integer *,
+	     real *, integer *, real *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    real bignum;
+    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
+	    real *, integer *, integer *, real *, integer *, integer *), sgeqpf_(integer *, integer *, real *, integer *, integer 
+	    *, real *, real *, integer *), slaset_(char *, integer *, integer 
+	    *, real *, real *, real *, integer *);
+    real sminpr, smaxpr, smlnum;
+    extern /* Subroutine */ int slatzm_(char *, integer *, integer *, real *, 
+	    integer *, real *, real *, real *, integer *, real *), 
+	    stzrqf_(integer *, integer *, real *, integer *, real *, integer *
+	    );
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --jpvt;
+    --work;
+
+    /* Function Body */
+    mn = f2cmin(*m,*n);
+    ismin = mn + 1;
+    ismax = (mn << 1) + 1;
+
+/*     Test the input arguments. */
+
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -5;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = f2cmax(1,*m);
+	if (*ldb < f2cmax(i__1,*n)) {
+	    *info = -7;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SGELSX", &i__1);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+/* Computing MIN */
+    i__1 = f2cmin(*m,*n);
+    if (f2cmin(i__1,*nrhs) == 0) {
+	*rank = 0;
+	return 0;
+    }
+
+/*     Get machine parameters */
+
+    smlnum = slamch_("S") / slamch_("P");
+    bignum = 1.f / smlnum;
+    slabad_(&smlnum, &bignum);
+
+/*     Scale A, B if f2cmax elements outside range [SMLNUM,BIGNUM] */
+
+    anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]);
+    iascl = 0;
+    if (anrm > 0.f && anrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 1;
+    } else if (anrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 2;
+    } else if (anrm == 0.f) {
+
+/*        Matrix all zero. Return zero solution. */
+
+	i__1 = f2cmax(*m,*n);
+	slaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
+	*rank = 0;
+	goto L100;
+    }
+
+    bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+    ibscl = 0;
+    if (bnrm > 0.f && bnrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+		 info);
+	ibscl = 1;
+    } else if (bnrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+		 info);
+	ibscl = 2;
+    }
+
+/*     Compute QR factorization with column pivoting of A: */
+/*        A * P = Q * R */
+
+    sgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info);
+
+/*     workspace 3*N. Details of Householder rotations stored */
+/*     in WORK(1:MN). */
+
+/*     Determine RANK using incremental condition estimation */
+
+    work[ismin] = 1.f;
+    work[ismax] = 1.f;
+    smax = (r__1 = a[a_dim1 + 1], abs(r__1));
+    smin = smax;
+    if ((r__1 = a[a_dim1 + 1], abs(r__1)) == 0.f) {
+	*rank = 0;
+	i__1 = f2cmax(*m,*n);
+	slaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
+	goto L100;
+    } else {
+	*rank = 1;
+    }
+
+L10:
+    if (*rank < mn) {
+	i__ = *rank + 1;
+	slaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+		i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+	slaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+		i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+	if (smaxpr * *rcond <= sminpr) {
+	    i__1 = *rank;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
+		work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
+/* L20: */
+	    }
+	    work[ismin + *rank] = c1;
+	    work[ismax + *rank] = c2;
+	    smin = sminpr;
+	    smax = smaxpr;
+	    ++(*rank);
+	    goto L10;
+	}
+    }
+
+/*     Logically partition R = [ R11 R12 ] */
+/*                             [  0  R22 ] */
+/*     where R11 = R(1:RANK,1:RANK) */
+
+/*     [R11,R12] = [ T11, 0 ] * Y */
+
+    if (*rank < *n) {
+	stzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
+    }
+
+/*     Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/*     B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) */
+
+    sorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
+	    b[b_offset], ldb, &work[(mn << 1) + 1], info);
+
+/*     workspace NRHS */
+
+/*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+    strsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, &
+	    a[a_offset], lda, &b[b_offset], ldb);
+
+    i__1 = *n;
+    for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+	i__2 = *nrhs;
+	for (j = 1; j <= i__2; ++j) {
+	    b[i__ + j * b_dim1] = 0.f;
+/* L30: */
+	}
+/* L40: */
+    }
+
+/*     B(1:N,1:NRHS) := Y**T * B(1:N,1:NRHS) */
+
+    if (*rank < *n) {
+	i__1 = *rank;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n - *rank + 1;
+	    slatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, 
+		    &work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1],
+		     ldb, &work[(mn << 1) + 1]);
+/* L50: */
+	}
+    }
+
+/*     workspace NRHS */
+
+/*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+    i__1 = *nrhs;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    work[(mn << 1) + i__] = 1.f;
+/* L60: */
+	}
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    if (work[(mn << 1) + i__] == 1.f) {
+		if (jpvt[i__] != i__) {
+		    k = i__;
+		    t1 = b[k + j * b_dim1];
+		    t2 = b[jpvt[k] + j * b_dim1];
+L70:
+		    b[jpvt[k] + j * b_dim1] = t1;
+		    work[(mn << 1) + k] = 0.f;
+		    t1 = t2;
+		    k = jpvt[k];
+		    t2 = b[jpvt[k] + j * b_dim1];
+		    if (jpvt[k] != i__) {
+			goto L70;
+		    }
+		    b[i__ + j * b_dim1] = t1;
+		    work[(mn << 1) + k] = 0.f;
+		}
+	    }
+/* L80: */
+	}
+/* L90: */
+    }
+
+/*     Undo scaling */
+
+    if (iascl == 1) {
+	slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+		 info);
+	slascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], 
+		lda, info);
+    } else if (iascl == 2) {
+	slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+		 info);
+	slascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], 
+		lda, info);
+    }
+    if (ibscl == 1) {
+	slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+		 info);
+    } else if (ibscl == 2) {
+	slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+		 info);
+    }
+
+L100:
+
+    return 0;
+
+/*     End of SGELSX */
+
+} /* sgelsx_ */
+

lapack-netlib/SRC/DEPRECATED/sgeqpf.c

@@ -0,0 +1,729 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* > \brief \b SGEQPF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SGEQPF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgeqpf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgeqpf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgeqpf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, M, N */
+/*       INTEGER            JPVT( * ) */
+/*       REAL               A( LDA, * ), TAU( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine SGEQP3. */
+/* > */
+/* > SGEQPF computes a QR factorization with column pivoting of a */
+/* > real M-by-N matrix A: A*P = Q*R. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A. M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A. N >= 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, the upper triangle of the array contains the */
+/* >          f2cmin(M,N)-by-N upper triangular matrix R; the elements */
+/* >          below the diagonal, together with the array TAU, */
+/* >          represent the orthogonal matrix Q as a product of */
+/* >          f2cmin(m,n) elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JPVT */
+/* > \verbatim */
+/* >          JPVT is INTEGER array, dimension (N) */
+/* >          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* >          to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* >          the i-th column of A is a free column. */
+/* >          On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* >          was the k-th column of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (f2cmin(M,N)) */
+/* >          The scalar factors of the elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (3*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realGEcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The matrix Q is represented as a product of elementary reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(n) */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
+/* > */
+/* >  The matrix P is represented in jpvt as follows: If */
+/* >     jpvt(j) = i */
+/* >  then the jth column of P is the ith canonical unit vector. */
+/* > */
+/* >  Partial column norm updating strategy modified by */
+/* >    Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* >    University of Zagreb, Croatia. */
+/* >  -- April 2011                                                      -- */
+/* >  For more details see LAPACK Working Note 176. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int sgeqpf_(integer *m, integer *n, real *a, integer *lda, 
+	integer *jpvt, real *tau, real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    real r__1, r__2;
+
+    /* Local variables */
+    real temp, temp2;
+    extern real snrm2_(integer *, real *, integer *);
+    integer i__, j;
+    real tol3z;
+    extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, 
+	    integer *, real *, real *, integer *, real *);
+    integer itemp;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *), sgeqr2_(integer *, integer *, real *, integer *, real 
+	    *, real *, integer *);
+    integer ma;
+    extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *, 
+	    integer *, real *, integer *, real *, real *, integer *, real *, 
+	    integer *);
+    integer mn;
+    extern real slamch_(char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *), slarfg_(
+	    integer *, real *, real *, integer *, real *);
+    extern integer isamax_(integer *, real *, integer *);
+    real aii;
+    integer pvt;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --jpvt;
+    --tau;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SGEQPF", &i__1);
+	return 0;
+    }
+
+    mn = f2cmin(*m,*n);
+    tol3z = sqrt(slamch_("Epsilon"));
+
+/*     Move initial columns up front */
+
+    itemp = 1;
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (jpvt[i__] != 0) {
+	    if (i__ != itemp) {
+		sswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
+			 &c__1);
+		jpvt[i__] = jpvt[itemp];
+		jpvt[itemp] = i__;
+	    } else {
+		jpvt[i__] = i__;
+	    }
+	    ++itemp;
+	} else {
+	    jpvt[i__] = i__;
+	}
+/* L10: */
+    }
+    --itemp;
+
+/*     Compute the QR factorization and update remaining columns */
+
+    if (itemp > 0) {
+	ma = f2cmin(itemp,*m);
+	sgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
+	if (ma < *n) {
+	    i__1 = *n - ma;
+	    sorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, &
+		    tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info);
+	}
+    }
+
+    if (itemp < mn) {
+
+/*        Initialize partial column norms. The first n elements of */
+/*        work store the exact column norms. */
+
+	i__1 = *n;
+	for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+	    i__2 = *m - itemp;
+	    work[i__] = snrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
+	    work[*n + i__] = work[i__];
+/* L20: */
+	}
+
+/*        Compute factorization */
+
+	i__1 = mn;
+	for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+
+/*           Determine ith pivot column and swap if necessary */
+
+	    i__2 = *n - i__ + 1;
+	    pvt = i__ - 1 + isamax_(&i__2, &work[i__], &c__1);
+
+	    if (pvt != i__) {
+		sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+			c__1);
+		itemp = jpvt[pvt];
+		jpvt[pvt] = jpvt[i__];
+		jpvt[i__] = itemp;
+		work[pvt] = work[i__];
+		work[*n + pvt] = work[*n + i__];
+	    }
+
+/*           Generate elementary reflector H(i) */
+
+	    if (i__ < *m) {
+		i__2 = *m - i__ + 1;
+		slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ * 
+			a_dim1], &c__1, &tau[i__]);
+	    } else {
+		slarfg_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], &
+			c__1, &tau[*m]);
+	    }
+
+	    if (i__ < *n) {
+
+/*              Apply H(i) to A(i:m,i+1:n) from the left */
+
+		aii = a[i__ + i__ * a_dim1];
+		a[i__ + i__ * a_dim1] = 1.f;
+		i__2 = *m - i__ + 1;
+		i__3 = *n - i__;
+		slarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+			tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(*
+			n << 1) + 1]);
+		a[i__ + i__ * a_dim1] = aii;
+	    }
+
+/*           Update partial column norms */
+
+	    i__2 = *n;
+	    for (j = i__ + 1; j <= i__2; ++j) {
+		if (work[j] != 0.f) {
+
+/*                 NOTE: The following 4 lines follow from the analysis in */
+/*                 Lapack Working Note 176. */
+
+		    temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)) / work[j];
+/* Computing MAX */
+		    r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
+		    temp = f2cmax(r__1,r__2);
+/* Computing 2nd power */
+		    r__1 = work[j] / work[*n + j];
+		    temp2 = temp * (r__1 * r__1);
+		    if (temp2 <= tol3z) {
+			if (*m - i__ > 0) {
+			    i__3 = *m - i__;
+			    work[j] = snrm2_(&i__3, &a[i__ + 1 + j * a_dim1], 
+				    &c__1);
+			    work[*n + j] = work[j];
+			} else {
+			    work[j] = 0.f;
+			    work[*n + j] = 0.f;
+			}
+		    } else {
+			work[j] *= sqrt(temp);
+		    }
+		}
+/* L30: */
+	    }
+
+/* L40: */
+	}
+    }
+    return 0;
+
+/*     End of SGEQPF */
+
+} /* sgeqpf_ */
+

lapack-netlib/SRC/DEPRECATED/sggsvd.c

@@ -0,0 +1,884 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* > \brief <b> SGGSVD computes the singular value decomposition (SVD) for OTHER matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SGGSVD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sggsvd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sggsvd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sggsvd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */
+/*                          LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */
+/*                          IWORK, INFO ) */
+
+/*       CHARACTER          JOBQ, JOBU, JOBV */
+/*       INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               A( LDA, * ), ALPHA( * ), B( LDB, * ), */
+/*      $                   BETA( * ), Q( LDQ, * ), U( LDU, * ), */
+/*      $                   V( LDV, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine SGGSVD3. */
+/* > */
+/* > SGGSVD computes the generalized singular value decomposition (GSVD) */
+/* > of an M-by-N real matrix A and P-by-N real matrix B: */
+/* > */
+/* >       U**T*A*Q = D1*( 0 R ),    V**T*B*Q = D2*( 0 R ) */
+/* > */
+/* > where U, V and Q are orthogonal matrices. */
+/* > Let K+L = the effective numerical rank of the matrix (A**T,B**T)**T, */
+/* > then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */
+/* > D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */
+/* > following structures, respectively: */
+/* > */
+/* > If M-K-L >= 0, */
+/* > */
+/* >                     K  L */
+/* >        D1 =     K ( I  0 ) */
+/* >                 L ( 0  C ) */
+/* >             M-K-L ( 0  0 ) */
+/* > */
+/* >                   K  L */
+/* >        D2 =   L ( 0  S ) */
+/* >             P-L ( 0  0 ) */
+/* > */
+/* >                 N-K-L  K    L */
+/* >   ( 0 R ) = K (  0   R11  R12 ) */
+/* >             L (  0    0   R22 ) */
+/* > */
+/* > where */
+/* > */
+/* >   C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* >   S = diag( BETA(K+1),  ... , BETA(K+L) ), */
+/* >   C**2 + S**2 = I. */
+/* > */
+/* >   R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+/* > */
+/* > If M-K-L < 0, */
+/* > */
+/* >                   K M-K K+L-M */
+/* >        D1 =   K ( I  0    0   ) */
+/* >             M-K ( 0  C    0   ) */
+/* > */
+/* >                     K M-K K+L-M */
+/* >        D2 =   M-K ( 0  S    0  ) */
+/* >             K+L-M ( 0  0    I  ) */
+/* >               P-L ( 0  0    0  ) */
+/* > */
+/* >                    N-K-L  K   M-K  K+L-M */
+/* >   ( 0 R ) =     K ( 0    R11  R12  R13  ) */
+/* >               M-K ( 0     0   R22  R23  ) */
+/* >             K+L-M ( 0     0    0   R33  ) */
+/* > */
+/* > where */
+/* > */
+/* >   C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* >   S = diag( BETA(K+1),  ... , BETA(M) ), */
+/* >   C**2 + S**2 = I. */
+/* > */
+/* >   (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */
+/* >   ( 0  R22 R23 ) */
+/* >   in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+/* > */
+/* > The routine computes C, S, R, and optionally the orthogonal */
+/* > transformation matrices U, V and Q. */
+/* > */
+/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */
+/* > A and B implicitly gives the SVD of A*inv(B): */
+/* >                      A*inv(B) = U*(D1*inv(D2))*V**T. */
+/* > If ( A**T,B**T)**T  has orthonormal columns, then the GSVD of A and B is */
+/* > also equal to the CS decomposition of A and B. Furthermore, the GSVD */
+/* > can be used to derive the solution of the eigenvalue problem: */
+/* >                      A**T*A x = lambda* B**T*B x. */
+/* > In some literature, the GSVD of A and B is presented in the form */
+/* >                  U**T*A*X = ( 0 D1 ),   V**T*B*X = ( 0 D2 ) */
+/* > where U and V are orthogonal and X is nonsingular, D1 and D2 are */
+/* > ``diagonal''.  The former GSVD form can be converted to the latter */
+/* > form by taking the nonsingular matrix X as */
+/* > */
+/* >                      X = Q*( I   0    ) */
+/* >                            ( 0 inv(R) ). */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBU */
+/* > \verbatim */
+/* >          JOBU is CHARACTER*1 */
+/* >          = 'U':  Orthogonal matrix U is computed; */
+/* >          = 'N':  U is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBV */
+/* > \verbatim */
+/* >          JOBV is CHARACTER*1 */
+/* >          = 'V':  Orthogonal matrix V is computed; */
+/* >          = 'N':  V is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBQ */
+/* > \verbatim */
+/* >          JOBQ is CHARACTER*1 */
+/* >          = 'Q':  Orthogonal matrix Q is computed; */
+/* >          = 'N':  Q is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] P */
+/* > \verbatim */
+/* >          P is INTEGER */
+/* >          The number of rows of the matrix B.  P >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* > \endverbatim */
+/* > */
+/* > \param[out] L */
+/* > \verbatim */
+/* >          L is INTEGER */
+/* > */
+/* >          On exit, K and L specify the dimension of the subblocks */
+/* >          described in Purpose. */
+/* >          K + L = effective numerical rank of (A**T,B**T)**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A contains the triangular matrix R, or part of R. */
+/* >          See Purpose for details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,N) */
+/* >          On entry, the P-by-N matrix B. */
+/* >          On exit, B contains the triangular matrix R if M-K-L < 0. */
+/* >          See Purpose for details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,P). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] BETA */
+/* > \verbatim */
+/* >          BETA is REAL array, dimension (N) */
+/* > */
+/* >          On exit, ALPHA and BETA contain the generalized singular */
+/* >          value pairs of A and B; */
+/* >            ALPHA(1:K) = 1, */
+/* >            BETA(1:K)  = 0, */
+/* >          and if M-K-L >= 0, */
+/* >            ALPHA(K+1:K+L) = C, */
+/* >            BETA(K+1:K+L)  = S, */
+/* >          or if M-K-L < 0, */
+/* >            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */
+/* >            BETA(K+1:M) =S, BETA(M+1:K+L) =1 */
+/* >          and */
+/* >            ALPHA(K+L+1:N) = 0 */
+/* >            BETA(K+L+1:N)  = 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[out] U */
+/* > \verbatim */
+/* >          U is REAL array, dimension (LDU,M) */
+/* >          If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */
+/* >          If JOBU = 'N', U is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDU */
+/* > \verbatim */
+/* >          LDU is INTEGER */
+/* >          The leading dimension of the array U. LDU >= f2cmax(1,M) if */
+/* >          JOBU = 'U'; LDU >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] V */
+/* > \verbatim */
+/* >          V is REAL array, dimension (LDV,P) */
+/* >          If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */
+/* >          If JOBV = 'N', V is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDV */
+/* > \verbatim */
+/* >          LDV is INTEGER */
+/* >          The leading dimension of the array V. LDV >= f2cmax(1,P) if */
+/* >          JOBV = 'V'; LDV >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Q */
+/* > \verbatim */
+/* >          Q is REAL array, dimension (LDQ,N) */
+/* >          If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */
+/* >          If JOBQ = 'N', Q is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDQ */
+/* > \verbatim */
+/* >          LDQ is INTEGER */
+/* >          The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */
+/* >          JOBQ = 'Q'; LDQ >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, */
+/* >                      dimension (f2cmax(3*N,M,P)+N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* >          On exit, IWORK stores the sorting information. More */
+/* >          precisely, the following loop will sort ALPHA */
+/* >             for I = K+1, f2cmin(M,K+L) */
+/* >                 swap ALPHA(I) and ALPHA(IWORK(I)) */
+/* >             endfor */
+/* >          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* >          > 0:  if INFO = 1, the Jacobi-type procedure failed to */
+/* >                converge.  For further details, see subroutine STGSJA. */
+/* > \endverbatim */
+
+/* > \par Internal Parameters: */
+/*  ========================= */
+/* > */
+/* > \verbatim */
+/* >  TOLA    REAL */
+/* >  TOLB    REAL */
+/* >          TOLA and TOLB are the thresholds to determine the effective */
+/* >          rank of (A**T,B**T)**T. Generally, they are set to */
+/* >                   TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* >                   TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+/* >          The size of TOLA and TOLB may affect the size of backward */
+/* >          errors of the decomposition. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERsing */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* >     Ming Gu and Huan Ren, Computer Science Division, University of */
+/* >     California at Berkeley, USA */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int sggsvd_(char *jobu, char *jobv, char *jobq, integer *m, 
+	integer *n, integer *p, integer *k, integer *l, real *a, integer *lda,
+	 real *b, integer *ldb, real *alpha, real *beta, real *u, integer *
+	ldu, real *v, integer *ldv, real *q, integer *ldq, real *work, 
+	integer *iwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, 
+	    u_offset, v_dim1, v_offset, i__1, i__2;
+
+    /* Local variables */
+    integer ibnd;
+    real tola;
+    integer isub;
+    real tolb, unfl, temp, smax;
+    integer ncallmycycle, i__, j;
+    extern logical lsame_(char *, char *);
+    real anorm, bnorm;
+    logical wantq;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *);
+    logical wantu, wantv;
+    extern real slamch_(char *), slange_(char *, integer *, integer *,
+	     real *, integer *, real *);
+    extern /* Subroutine */ int xerbla_(char *, integer *), stgsja_(
+	    char *, char *, char *, integer *, integer *, integer *, integer *
+	    , integer *, real *, integer *, real *, integer *, real *, real *,
+	     real *, real *, real *, integer *, real *, integer *, real *, 
+	    integer *, real *, integer *, integer *), 
+	    sggsvp_(char *, char *, char *, integer *, integer *, integer *, 
+	    real *, integer *, real *, integer *, real *, real *, integer *, 
+	    integer *, real *, integer *, real *, integer *, real *, integer *
+	    , integer *, real *, real *, integer *);
+    real ulp;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --alpha;
+    --beta;
+    u_dim1 = *ldu;
+    u_offset = 1 + u_dim1 * 1;
+    u -= u_offset;
+    v_dim1 = *ldv;
+    v_offset = 1 + v_dim1 * 1;
+    v -= v_offset;
+    q_dim1 = *ldq;
+    q_offset = 1 + q_dim1 * 1;
+    q -= q_offset;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    wantu = lsame_(jobu, "U");
+    wantv = lsame_(jobv, "V");
+    wantq = lsame_(jobq, "Q");
+
+    *info = 0;
+    if (! (wantu || lsame_(jobu, "N"))) {
+	*info = -1;
+    } else if (! (wantv || lsame_(jobv, "N"))) {
+	*info = -2;
+    } else if (! (wantq || lsame_(jobq, "N"))) {
+	*info = -3;
+    } else if (*m < 0) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -5;
+    } else if (*p < 0) {
+	*info = -6;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -10;
+    } else if (*ldb < f2cmax(1,*p)) {
+	*info = -12;
+    } else if (*ldu < 1 || wantu && *ldu < *m) {
+	*info = -16;
+    } else if (*ldv < 1 || wantv && *ldv < *p) {
+	*info = -18;
+    } else if (*ldq < 1 || wantq && *ldq < *n) {
+	*info = -20;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SGGSVD", &i__1);
+	return 0;
+    }
+
+/*     Compute the Frobenius norm of matrices A and B */
+
+    anorm = slange_("1", m, n, &a[a_offset], lda, &work[1]);
+    bnorm = slange_("1", p, n, &b[b_offset], ldb, &work[1]);
+
+/*     Get machine precision and set up threshold for determining */
+/*     the effective numerical rank of the matrices A and B. */
+
+    ulp = slamch_("Precision");
+    unfl = slamch_("Safe Minimum");
+    tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp;
+    tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp;
+
+/*     Preprocessing */
+
+    sggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, &
+	    tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[
+	    q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], info);
+
+/*     Compute the GSVD of two upper "triangular" matrices */
+
+    stgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], 
+	    ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+	    v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info);
+
+/*     Sort the singular values and store the pivot indices in IWORK */
+/*     Copy ALPHA to WORK, then sort ALPHA in WORK */
+
+    scopy_(n, &alpha[1], &c__1, &work[1], &c__1);
+/* Computing MIN */
+    i__1 = *l, i__2 = *m - *k;
+    ibnd = f2cmin(i__1,i__2);
+    i__1 = ibnd;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        Scan for largest ALPHA(K+I) */
+
+	isub = i__;
+	smax = work[*k + i__];
+	i__2 = ibnd;
+	for (j = i__ + 1; j <= i__2; ++j) {
+	    temp = work[*k + j];
+	    if (temp > smax) {
+		isub = j;
+		smax = temp;
+	    }
+/* L10: */
+	}
+	if (isub != i__) {
+	    work[*k + isub] = work[*k + i__];
+	    work[*k + i__] = smax;
+	    iwork[*k + i__] = *k + isub;
+	} else {
+	    iwork[*k + i__] = *k + i__;
+	}
+/* L20: */
+    }
+
+    return 0;
+
+/*     End of SGGSVD */
+
+} /* sggsvd_ */
+

lapack-netlib/SRC/DEPRECATED/sggsvp.c

@@ -0,0 +1,989 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static real c_b12 = 0.f;
+static real c_b22 = 1.f;
+
+/* > \brief \b SGGSVP */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SGGSVP + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sggsvp.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sggsvp.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sggsvp.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, */
+/*                          TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, */
+/*                          IWORK, TAU, WORK, INFO ) */
+
+/*       CHARACTER          JOBQ, JOBU, JOBV */
+/*       INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */
+/*       REAL               TOLA, TOLB */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */
+/*      $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine SGGSVP3. */
+/* > */
+/* > SGGSVP computes orthogonal matrices U, V and Q such that */
+/* > */
+/* >                    N-K-L  K    L */
+/* >  U**T*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0; */
+/* >                 L ( 0     0   A23 ) */
+/* >             M-K-L ( 0     0    0  ) */
+/* > */
+/* >                  N-K-L  K    L */
+/* >         =     K ( 0    A12  A13 )  if M-K-L < 0; */
+/* >             M-K ( 0     0   A23 ) */
+/* > */
+/* >                  N-K-L  K    L */
+/* >  V**T*B*Q =   L ( 0     0   B13 ) */
+/* >             P-L ( 0     0    0  ) */
+/* > */
+/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* > otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective */
+/* > numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. */
+/* > */
+/* > This decomposition is the preprocessing step for computing the */
+/* > Generalized Singular Value Decomposition (GSVD), see subroutine */
+/* > SGGSVD. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBU */
+/* > \verbatim */
+/* >          JOBU is CHARACTER*1 */
+/* >          = 'U':  Orthogonal matrix U is computed; */
+/* >          = 'N':  U is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBV */
+/* > \verbatim */
+/* >          JOBV is CHARACTER*1 */
+/* >          = 'V':  Orthogonal matrix V is computed; */
+/* >          = 'N':  V is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBQ */
+/* > \verbatim */
+/* >          JOBQ is CHARACTER*1 */
+/* >          = 'Q':  Orthogonal matrix Q is computed; */
+/* >          = 'N':  Q is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] P */
+/* > \verbatim */
+/* >          P is INTEGER */
+/* >          The number of rows of the matrix B.  P >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A contains the triangular (or trapezoidal) matrix */
+/* >          described in the Purpose section. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,N) */
+/* >          On entry, the P-by-N matrix B. */
+/* >          On exit, B contains the triangular matrix described in */
+/* >          the Purpose section. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,P). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TOLA */
+/* > \verbatim */
+/* >          TOLA is REAL */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TOLB */
+/* > \verbatim */
+/* >          TOLB is REAL */
+/* > */
+/* >          TOLA and TOLB are the thresholds to determine the effective */
+/* >          numerical rank of matrix B and a subblock of A. Generally, */
+/* >          they are set to */
+/* >             TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* >             TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+/* >          The size of TOLA and TOLB may affect the size of backward */
+/* >          errors of the decomposition. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* > \endverbatim */
+/* > */
+/* > \param[out] L */
+/* > \verbatim */
+/* >          L is INTEGER */
+/* > */
+/* >          On exit, K and L specify the dimension of the subblocks */
+/* >          described in Purpose section. */
+/* >          K + L = effective numerical rank of (A**T,B**T)**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] U */
+/* > \verbatim */
+/* >          U is REAL array, dimension (LDU,M) */
+/* >          If JOBU = 'U', U contains the orthogonal matrix U. */
+/* >          If JOBU = 'N', U is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDU */
+/* > \verbatim */
+/* >          LDU is INTEGER */
+/* >          The leading dimension of the array U. LDU >= f2cmax(1,M) if */
+/* >          JOBU = 'U'; LDU >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] V */
+/* > \verbatim */
+/* >          V is REAL array, dimension (LDV,P) */
+/* >          If JOBV = 'V', V contains the orthogonal matrix V. */
+/* >          If JOBV = 'N', V is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDV */
+/* > \verbatim */
+/* >          LDV is INTEGER */
+/* >          The leading dimension of the array V. LDV >= f2cmax(1,P) if */
+/* >          JOBV = 'V'; LDV >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Q */
+/* > \verbatim */
+/* >          Q is REAL array, dimension (LDQ,N) */
+/* >          If JOBQ = 'Q', Q contains the orthogonal matrix Q. */
+/* >          If JOBQ = 'N', Q is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDQ */
+/* > \verbatim */
+/* >          LDQ is INTEGER */
+/* >          The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */
+/* >          JOBQ = 'Q'; LDQ >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (f2cmax(3*N,M,P)) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* >  The subroutine uses LAPACK subroutine SGEQPF for the QR factorization */
+/* >  with column pivoting to detect the effective numerical rank of the */
+/* >  a matrix. It may be replaced by a better rank determination strategy. */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m, 
+	integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb, 
+	real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu,
+	 real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real *
+	tau, real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, 
+	    u_offset, v_dim1, v_offset, i__1, i__2, i__3;
+    real r__1;
+
+    /* Local variables */
+    integer i__, j;
+    extern logical lsame_(char *, char *);
+    logical wantq, wantu, wantv;
+    extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer 
+	    *, real *, real *, integer *), sgerq2_(integer *, integer *, real 
+	    *, integer *, real *, real *, integer *), sorg2r_(integer *, 
+	    integer *, integer *, real *, integer *, real *, real *, integer *
+	    ), sorm2r_(char *, char *, integer *, integer *, integer *, real *
+	    , integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *,
+	     real *, integer *, real *, real *, integer *, real *, integer *), xerbla_(char *, integer *), sgeqpf_(
+	    integer *, integer *, real *, integer *, integer *, real *, real *
+	    , integer *), slacpy_(char *, integer *, integer *, real *, 
+	    integer *, real *, integer *), slaset_(char *, integer *, 
+	    integer *, real *, real *, real *, integer *), slapmt_(
+	    logical *, integer *, integer *, real *, integer *, integer *);
+    logical forwrd;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    u_dim1 = *ldu;
+    u_offset = 1 + u_dim1 * 1;
+    u -= u_offset;
+    v_dim1 = *ldv;
+    v_offset = 1 + v_dim1 * 1;
+    v -= v_offset;
+    q_dim1 = *ldq;
+    q_offset = 1 + q_dim1 * 1;
+    q -= q_offset;
+    --iwork;
+    --tau;
+    --work;
+
+    /* Function Body */
+    wantu = lsame_(jobu, "U");
+    wantv = lsame_(jobv, "V");
+    wantq = lsame_(jobq, "Q");
+    forwrd = TRUE_;
+
+    *info = 0;
+    if (! (wantu || lsame_(jobu, "N"))) {
+	*info = -1;
+    } else if (! (wantv || lsame_(jobv, "N"))) {
+	*info = -2;
+    } else if (! (wantq || lsame_(jobq, "N"))) {
+	*info = -3;
+    } else if (*m < 0) {
+	*info = -4;
+    } else if (*p < 0) {
+	*info = -5;
+    } else if (*n < 0) {
+	*info = -6;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -8;
+    } else if (*ldb < f2cmax(1,*p)) {
+	*info = -10;
+    } else if (*ldu < 1 || wantu && *ldu < *m) {
+	*info = -16;
+    } else if (*ldv < 1 || wantv && *ldv < *p) {
+	*info = -18;
+    } else if (*ldq < 1 || wantq && *ldq < *n) {
+	*info = -20;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SGGSVP", &i__1);
+	return 0;
+    }
+
+/*     QR with column pivoting of B: B*P = V*( S11 S12 ) */
+/*                                           (  0   0  ) */
+
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	iwork[i__] = 0;
+/* L10: */
+    }
+    sgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
+
+/*     Update A := A*P */
+
+    slapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
+
+/*     Determine the effective rank of matrix B. */
+
+    *l = 0;
+    i__1 = f2cmin(*p,*n);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if ((r__1 = b[i__ + i__ * b_dim1], abs(r__1)) > *tolb) {
+	    ++(*l);
+	}
+/* L20: */
+    }
+
+    if (wantv) {
+
+/*        Copy the details of V, and form V. */
+
+	slaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv);
+	if (*p > 1) {
+	    i__1 = *p - 1;
+	    slacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], 
+		    ldv);
+	}
+	i__1 = f2cmin(*p,*n);
+	sorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
+    }
+
+/*     Clean up B */
+
+    i__1 = *l - 1;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *l;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    b[i__ + j * b_dim1] = 0.f;
+/* L30: */
+	}
+/* L40: */
+    }
+    if (*p > *l) {
+	i__1 = *p - *l;
+	slaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb);
+    }
+
+    if (wantq) {
+
+/*        Set Q = I and Update Q := Q*P */
+
+	slaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq);
+	slapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
+    }
+
+    if (*p >= *l && *n != *l) {
+
+/*        RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
+
+	sgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
+
+/*        Update A := A*Z**T */
+
+	sormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[
+		a_offset], lda, &work[1], info);
+
+	if (wantq) {
+
+/*           Update Q := Q*Z**T */
+
+	    sormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1],
+		     &q[q_offset], ldq, &work[1], info);
+	}
+
+/*        Clean up B */
+
+	i__1 = *n - *l;
+	slaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb);
+	i__1 = *n;
+	for (j = *n - *l + 1; j <= i__1; ++j) {
+	    i__2 = *l;
+	    for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
+		b[i__ + j * b_dim1] = 0.f;
+/* L50: */
+	    }
+/* L60: */
+	}
+
+    }
+
+/*     Let              N-L     L */
+/*                A = ( A11    A12 ) M, */
+
+/*     then the following does the complete QR decomposition of A11: */
+
+/*              A11 = U*(  0  T12 )*P1**T */
+/*                      (  0   0  ) */
+
+    i__1 = *n - *l;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	iwork[i__] = 0;
+/* L70: */
+    }
+    i__1 = *n - *l;
+    sgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info);
+
+/*     Determine the effective rank of A11 */
+
+    *k = 0;
+/* Computing MIN */
+    i__2 = *m, i__3 = *n - *l;
+    i__1 = f2cmin(i__2,i__3);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if ((r__1 = a[i__ + i__ * a_dim1], abs(r__1)) > *tola) {
+	    ++(*k);
+	}
+/* L80: */
+    }
+
+/*     Update A12 := U**T*A12, where A12 = A( 1:M, N-L+1:N ) */
+
+/* Computing MIN */
+    i__2 = *m, i__3 = *n - *l;
+    i__1 = f2cmin(i__2,i__3);
+    sorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[(
+	    *n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
+
+    if (wantu) {
+
+/*        Copy the details of U, and form U */
+
+	slaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu);
+	if (*m > 1) {
+	    i__1 = *m - 1;
+	    i__2 = *n - *l;
+	    slacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2]
+		    , ldu);
+	}
+/* Computing MIN */
+	i__2 = *m, i__3 = *n - *l;
+	i__1 = f2cmin(i__2,i__3);
+	sorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
+    }
+
+    if (wantq) {
+
+/*        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1 */
+
+	i__1 = *n - *l;
+	slapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
+    }
+
+/*     Clean up A: set the strictly lower triangular part of */
+/*     A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
+
+    i__1 = *k - 1;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *k;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    a[i__ + j * a_dim1] = 0.f;
+/* L90: */
+	}
+/* L100: */
+    }
+    if (*m > *k) {
+	i__1 = *m - *k;
+	i__2 = *n - *l;
+	slaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1], 
+		lda);
+    }
+
+    if (*n - *l > *k) {
+
+/*        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
+
+	i__1 = *n - *l;
+	sgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
+
+	if (wantq) {
+
+/*           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**T */
+
+	    i__1 = *n - *l;
+	    sormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, &
+		    tau[1], &q[q_offset], ldq, &work[1], info);
+	}
+
+/*        Clean up A */
+
+	i__1 = *n - *l - *k;
+	slaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda);
+	i__1 = *n - *l;
+	for (j = *n - *l - *k + 1; j <= i__1; ++j) {
+	    i__2 = *k;
+	    for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] = 0.f;
+/* L110: */
+	    }
+/* L120: */
+	}
+
+    }
+
+    if (*m > *k) {
+
+/*        QR factorization of A( K+1:M,N-L+1:N ) */
+
+	i__1 = *m - *k;
+	sgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &
+		work[1], info);
+
+	if (wantu) {
+
+/*           Update U(:,K+1:M) := U(:,K+1:M)*U1 */
+
+	    i__1 = *m - *k;
+/* Computing MIN */
+	    i__3 = *m - *k;
+	    i__2 = f2cmin(i__3,*l);
+	    sorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n 
+		    - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + 
+		    1], ldu, &work[1], info);
+	}
+
+/*        Clean up */
+
+	i__1 = *n;
+	for (j = *n - *l + 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] = 0.f;
+/* L130: */
+	    }
+/* L140: */
+	}
+
+    }
+
+    return 0;
+
+/*     End of SGGSVP */
+
+} /* sggsvp_ */
+

lapack-netlib/SRC/DEPRECATED/slahrd.c

@@ -0,0 +1,718 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static real c_b4 = -1.f;
+static real c_b5 = 1.f;
+static integer c__1 = 1;
+static real c_b38 = 0.f;
+
+/* > \brief \b SLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below th
+e k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformati
+on to the unreduced part of A. */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SLAHRD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slahrd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slahrd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slahrd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */
+
+/*       INTEGER            K, LDA, LDT, LDY, N, NB */
+/*       REAL               A( LDA, * ), T( LDT, NB ), TAU( NB ), */
+/*      $                   Y( LDY, NB ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine SLAHR2. */
+/* > */
+/* > SLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */
+/* > matrix A so that elements below the k-th subdiagonal are zero. The */
+/* > reduction is performed by an orthogonal similarity transformation */
+/* > Q**T * A * Q. The routine returns the matrices V and T which determine */
+/* > Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The offset for the reduction. Elements below the k-th */
+/* >          subdiagonal in the first NB columns are reduced to zero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NB */
+/* > \verbatim */
+/* >          NB is INTEGER */
+/* >          The number of columns to be reduced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N-K+1) */
+/* >          On entry, the n-by-(n-k+1) general matrix A. */
+/* >          On exit, the elements on and above the k-th subdiagonal in */
+/* >          the first NB columns are overwritten with the corresponding */
+/* >          elements of the reduced matrix; the elements below the k-th */
+/* >          subdiagonal, with the array TAU, represent the matrix Q as a */
+/* >          product of elementary reflectors. The other columns of A are */
+/* >          unchanged. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (NB) */
+/* >          The scalar factors of the elementary reflectors. See Further */
+/* >          Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] T */
+/* > \verbatim */
+/* >          T is REAL array, dimension (LDT,NB) */
+/* >          The upper triangular matrix T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDT */
+/* > \verbatim */
+/* >          LDT is INTEGER */
+/* >          The leading dimension of the array T.  LDT >= NB. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Y */
+/* > \verbatim */
+/* >          Y is REAL array, dimension (LDY,NB) */
+/* >          The n-by-nb matrix Y. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDY */
+/* > \verbatim */
+/* >          LDY is INTEGER */
+/* >          The leading dimension of the array Y. LDY >= N. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERauxiliary */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The matrix Q is represented as a product of nb elementary reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(nb). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* >  A(i+k+1:n,i), and tau in TAU(i). */
+/* > */
+/* >  The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* >  V which is needed, with T and Y, to apply the transformation to the */
+/* >  unreduced part of the matrix, using an update of the form: */
+/* >  A := (I - V*T*V**T) * (A - Y*V**T). */
+/* > */
+/* >  The contents of A on exit are illustrated by the following example */
+/* >  with n = 7, k = 3 and nb = 2: */
+/* > */
+/* >     ( a   h   a   a   a ) */
+/* >     ( a   h   a   a   a ) */
+/* >     ( a   h   a   a   a ) */
+/* >     ( h   h   a   a   a ) */
+/* >     ( v1  h   a   a   a ) */
+/* >     ( v1  v2  a   a   a ) */
+/* >     ( v1  v2  a   a   a ) */
+/* > */
+/* >  where a denotes an element of the original matrix A, h denotes a */
+/* >  modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* >  element of the vector defining H(i). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int slahrd_(integer *n, integer *k, integer *nb, real *a, 
+	integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, 
+	    i__3;
+    real r__1;
+
+    /* Local variables */
+    integer i__;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemv_(char *, integer *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *), scopy_(
+	    integer *, real *, integer *, real *, integer *), saxpy_(integer *
+	    , real *, real *, integer *, real *, integer *), strmv_(char *, 
+	    char *, char *, integer *, real *, integer *, real *, integer *);
+    real ei;
+    extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, 
+	    real *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Quick return if possible */
+
+    /* Parameter adjustments */
+    --tau;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    t_dim1 = *ldt;
+    t_offset = 1 + t_dim1 * 1;
+    t -= t_offset;
+    y_dim1 = *ldy;
+    y_offset = 1 + y_dim1 * 1;
+    y -= y_offset;
+
+    /* Function Body */
+    if (*n <= 1) {
+	return 0;
+    }
+
+    i__1 = *nb;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (i__ > 1) {
+
+/*           Update A(1:n,i) */
+
+/*           Compute i-th column of A - Y * V**T */
+
+	    i__2 = i__ - 1;
+	    sgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k 
+		    + i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], &
+		    c__1);
+
+/*           Apply I - V * T**T * V**T to this column (call it b) from the */
+/*           left, using the last column of T as workspace */
+
+/*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows) */
+/*                    ( V2 )             ( b2 ) */
+
+/*           where V1 is unit lower triangular */
+
+/*           w := V1**T * b1 */
+
+	    i__2 = i__ - 1;
+	    scopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + 
+		    1], &c__1);
+	    i__2 = i__ - 1;
+	    strmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1], 
+		    lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/*           w := w + V2**T *b2 */
+
+	    i__2 = *n - *k - i__ + 1;
+	    i__3 = i__ - 1;
+	    sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], 
+		    lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * 
+		    t_dim1 + 1], &c__1);
+
+/*           w := T**T *w */
+
+	    i__2 = i__ - 1;
+	    strmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt,
+		     &t[*nb * t_dim1 + 1], &c__1);
+
+/*           b2 := b2 - V2*w */
+
+	    i__2 = *n - *k - i__ + 1;
+	    i__3 = i__ - 1;
+	    sgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
+		     lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + 
+		    i__ * a_dim1], &c__1);
+
+/*           b1 := b1 - V1*w */
+
+	    i__2 = i__ - 1;
+	    strmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
+		    , lda, &t[*nb * t_dim1 + 1], &c__1);
+	    i__2 = i__ - 1;
+	    saxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ 
+		    * a_dim1], &c__1);
+
+	    a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
+	}
+
+/*        Generate the elementary reflector H(i) to annihilate */
+/*        A(k+i+1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+	i__3 = *k + i__ + 1;
+	slarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[f2cmin(i__3,*n) + i__ * 
+		a_dim1], &c__1, &tau[i__]);
+	ei = a[*k + i__ + i__ * a_dim1];
+	a[*k + i__ + i__ * a_dim1] = 1.f;
+
+/*        Compute  Y(1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	sgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1], 
+		lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ * 
+		y_dim1 + 1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = i__ - 1;
+	sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
+		a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + 
+		1], &c__1);
+	i__2 = i__ - 1;
+	sgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ * 
+		t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1);
+	sscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
+
+/*        Compute T(1:i,i) */
+
+	i__2 = i__ - 1;
+	r__1 = -tau[i__];
+	sscal_(&i__2, &r__1, &t[i__ * t_dim1 + 1], &c__1);
+	i__2 = i__ - 1;
+	strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, 
+		&t[i__ * t_dim1 + 1], &c__1)
+		;
+	t[i__ + i__ * t_dim1] = tau[i__];
+
+/* L10: */
+    }
+    a[*k + *nb + *nb * a_dim1] = ei;
+
+    return 0;
+
+/*     End of SLAHRD */
+
+} /* slahrd_ */
+

lapack-netlib/SRC/DEPRECATED/slatzm.c

@@ -0,0 +1,622 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b5 = 1.f;
+
+/* > \brief \b SLATZM */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SLATZM + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slatzm.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slatzm.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slatzm.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) */
+
+/*       CHARACTER          SIDE */
+/*       INTEGER            INCV, LDC, M, N */
+/*       REAL               TAU */
+/*       REAL               C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine SORMRZ. */
+/* > */
+/* > SLATZM applies a Householder matrix generated by STZRQF to a matrix. */
+/* > */
+/* > Let P = I - tau*u*u**T,   u = ( 1 ), */
+/* >                               ( v ) */
+/* > where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
+/* > SIDE = 'R'. */
+/* > */
+/* > If SIDE equals 'L', let */
+/* >        C = [ C1 ] 1 */
+/* >            [ C2 ] m-1 */
+/* >              n */
+/* > Then C is overwritten by P*C. */
+/* > */
+/* > If SIDE equals 'R', let */
+/* >        C = [ C1, C2 ] m */
+/* >               1  n-1 */
+/* > Then C is overwritten by C*P. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* >          SIDE is CHARACTER*1 */
+/* >          = 'L': form P * C */
+/* >          = 'R': form C * P */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* >          V is REAL array, dimension */
+/* >                  (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* >                  (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* >          The vector v in the representation of P. V is not used */
+/* >          if TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* >          INCV is INTEGER */
+/* >          The increment between elements of v. INCV <> 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* >          TAU is REAL */
+/* >          The value tau in the representation of P. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C1 */
+/* > \verbatim */
+/* >          C1 is REAL array, dimension */
+/* >                         (LDC,N) if SIDE = 'L' */
+/* >                         (M,1)   if SIDE = 'R' */
+/* >          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
+/* >          if SIDE = 'R'. */
+/* > */
+/* >          On exit, the first row of P*C if SIDE = 'L', or the first */
+/* >          column of C*P if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C2 */
+/* > \verbatim */
+/* >          C2 is REAL array, dimension */
+/* >                         (LDC, N)   if SIDE = 'L' */
+/* >                         (LDC, N-1) if SIDE = 'R' */
+/* >          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
+/* >          m x (n - 1) matrix C2 if SIDE = 'R'. */
+/* > */
+/* >          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
+/* >          if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* >          LDC is INTEGER */
+/* >          The leading dimension of the arrays C1 and C2. LDC >= (1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension */
+/* >                      (N) if SIDE = 'L' */
+/* >                      (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int slatzm_(char *side, integer *m, integer *n, real *v, 
+	integer *incv, real *tau, real *c1, real *c2, integer *ldc, real *
+	work)
+{
+    /* System generated locals */
+    integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, 
+	    real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *), 
+	    saxpy_(integer *, real *, real *, integer *, real *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    --v;
+    c2_dim1 = *ldc;
+    c2_offset = 1 + c2_dim1 * 1;
+    c2 -= c2_offset;
+    c1_dim1 = *ldc;
+    c1_offset = 1 + c1_dim1 * 1;
+    c1 -= c1_offset;
+    --work;
+
+    /* Function Body */
+    if (f2cmin(*m,*n) == 0 || *tau == 0.f) {
+	return 0;
+    }
+
+    if (lsame_(side, "L")) {
+
+/*        w :=  (C1 + v**T * C2)**T */
+
+	scopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
+	i__1 = *m - 1;
+	sgemv_("Transpose", &i__1, n, &c_b5, &c2[c2_offset], ldc, &v[1], incv,
+		 &c_b5, &work[1], &c__1);
+
+/*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w**T */
+/*        [ C2 ]    [ C2 ]        [ v ] */
+
+	r__1 = -(*tau);
+	saxpy_(n, &r__1, &work[1], &c__1, &c1[c1_offset], ldc);
+	i__1 = *m - 1;
+	r__1 = -(*tau);
+	sger_(&i__1, n, &r__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], 
+		ldc);
+
+    } else if (lsame_(side, "R")) {
+
+/*        w := C1 + C2 * v */
+
+	scopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
+	i__1 = *n - 1;
+	sgemv_("No transpose", m, &i__1, &c_b5, &c2[c2_offset], ldc, &v[1], 
+		incv, &c_b5, &work[1], &c__1);
+
+/*        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**T] */
+
+	r__1 = -(*tau);
+	saxpy_(m, &r__1, &work[1], &c__1, &c1[c1_offset], &c__1);
+	i__1 = *n - 1;
+	r__1 = -(*tau);
+	sger_(m, &i__1, &r__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], 
+		ldc);
+    }
+
+    return 0;
+
+/*     End of SLATZM */
+
+} /* slatzm_ */
+

lapack-netlib/SRC/DEPRECATED/stzrqf.c

@@ -0,0 +1,642 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = 1.f;
+
+/* > \brief \b STZRQF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download STZRQF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stzrqf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stzrqf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stzrqf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO ) */
+
+/*       INTEGER            INFO, LDA, M, N */
+/*       REAL               A( LDA, * ), TAU( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine STZRZF. */
+/* > */
+/* > STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
+/* > to upper triangular form by means of orthogonal transformations. */
+/* > */
+/* > The upper trapezoidal matrix A is factored as */
+/* > */
+/* >    A = ( R  0 ) * Z, */
+/* > */
+/* > where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
+/* > triangular matrix. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A.  N >= M. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the leading M-by-N upper trapezoidal part of the */
+/* >          array A must contain the matrix to be factorized. */
+/* >          On exit, the leading M-by-M upper triangular part of A */
+/* >          contains the upper triangular matrix R, and elements M+1 to */
+/* >          N of the first M rows of A, with the array TAU, represent the */
+/* >          orthogonal matrix Z as a product of M elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (M) */
+/* >          The scalar factors of the elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The factorization is obtained by Householder's method.  The kth */
+/* >  transformation matrix, Z( k ), which is used to introduce zeros into */
+/* >  the ( m - k + 1 )th row of A, is given in the form */
+/* > */
+/* >     Z( k ) = ( I     0   ), */
+/* >              ( 0  T( k ) ) */
+/* > */
+/* >  where */
+/* > */
+/* >     T( k ) = I - tau*u( k )*u( k )**T,   u( k ) = (   1    ), */
+/* >                                                   (   0    ) */
+/* >                                                   ( z( k ) ) */
+/* > */
+/* >  tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* >  tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* >  of X. */
+/* > */
+/* >  The scalar tau is returned in the kth element of TAU and the vector */
+/* >  u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* >  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* >  the upper triangular part of A. */
+/* > */
+/* >  Z is given by */
+/* > */
+/* >     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int stzrqf_(integer *m, integer *n, real *a, integer *lda, 
+	real *tau, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    integer i__, k;
+    extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, 
+	    real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *);
+    integer m1;
+    extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, 
+	    real *, integer *), xerbla_(char *, integer *), slarfg_(
+	    integer *, real *, real *, integer *, real *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --tau;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < *m) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("STZRQF", &i__1);
+	return 0;
+    }
+
+/*     Perform the factorization. */
+
+    if (*m == 0) {
+	return 0;
+    }
+    if (*m == *n) {
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    tau[i__] = 0.f;
+/* L10: */
+	}
+    } else {
+/* Computing MIN */
+	i__1 = *m + 1;
+	m1 = f2cmin(i__1,*n);
+	for (k = *m; k >= 1; --k) {
+
+/*           Use a Householder reflection to zero the kth row of A. */
+/*           First set up the reflection. */
+
+	    i__1 = *n - *m + 1;
+	    slarfg_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[
+		    k]);
+
+	    if (tau[k] != 0.f && k > 1) {
+
+/*              We now perform the operation  A := A*P( k ). */
+
+/*              Use the first ( k - 1 ) elements of TAU to store  a( k ), */
+/*              where  a( k ) consists of the first ( k - 1 ) elements of */
+/*              the  kth column  of  A.  Also  let  B  denote  the  first */
+/*              ( k - 1 ) rows of the last ( n - m ) columns of A. */
+
+		i__1 = k - 1;
+		scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
+
+/*              Form   w = a( k ) + B*z( k )  in TAU. */
+
+		i__1 = k - 1;
+		i__2 = *n - *m;
+		sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 + 
+			1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], &
+			c__1);
+
+/*              Now form  a( k ) := a( k ) - tau*w */
+/*              and       B      := B      - tau*w*z( k )**T. */
+
+		i__1 = k - 1;
+		r__1 = -tau[k];
+		saxpy_(&i__1, &r__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
+			c__1);
+		i__1 = k - 1;
+		i__2 = *n - *m;
+		r__1 = -tau[k];
+		sger_(&i__1, &i__2, &r__1, &tau[1], &c__1, &a[k + m1 * a_dim1]
+			, lda, &a[m1 * a_dim1 + 1], lda);
+	    }
+/* L20: */
+	}
+    }
+
+    return 0;
+
+/*     End of STZRQF */
+
+} /* stzrqf_ */
+

lapack-netlib/SRC/DEPRECATED/zgelsx.c

@@ -0,0 +1,908 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* > \brief <b> ZGELSX solves overdetermined or underdetermined systems for GE matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download ZGELSX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelsx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelsx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelsx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */
+/*                          WORK, RWORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, LDB, M, N, NRHS, RANK */
+/*       DOUBLE PRECISION   RCOND */
+/*       INTEGER            JPVT( * ) */
+/*       DOUBLE PRECISION   RWORK( * ) */
+/*       COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine ZGELSY. */
+/* > */
+/* > ZGELSX computes the minimum-norm solution to a complex linear least */
+/* > squares problem: */
+/* >     minimize || A * X - B || */
+/* > using a complete orthogonal factorization of A.  A is an M-by-N */
+/* > matrix which may be rank-deficient. */
+/* > */
+/* > Several right hand side vectors b and solution vectors x can be */
+/* > handled in a single call; they are stored as the columns of the */
+/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* > matrix X. */
+/* > */
+/* > The routine first computes a QR factorization with column pivoting: */
+/* >     A * P = Q * [ R11 R12 ] */
+/* >                 [  0  R22 ] */
+/* > with R11 defined as the largest leading submatrix whose estimated */
+/* > condition number is less than 1/RCOND.  The order of R11, RANK, */
+/* > is the effective rank of A. */
+/* > */
+/* > Then, R22 is considered to be negligible, and R12 is annihilated */
+/* > by unitary transformations from the right, arriving at the */
+/* > complete orthogonal factorization: */
+/* >    A * P = Q * [ T11 0 ] * Z */
+/* >                [  0  0 ] */
+/* > The minimum-norm solution is then */
+/* >    X = P * Z**H [ inv(T11)*Q1**H*B ] */
+/* >                 [        0         ] */
+/* > where Q1 consists of the first RANK columns of Q. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of */
+/* >          columns of matrices B and X. NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A has been overwritten by details of its */
+/* >          complete orthogonal factorization. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is COMPLEX*16 array, dimension (LDB,NRHS) */
+/* >          On entry, the M-by-NRHS right hand side matrix B. */
+/* >          On exit, the N-by-NRHS solution matrix X. */
+/* >          If m >= n and RANK = n, the residual sum-of-squares for */
+/* >          the solution in the i-th column is given by the sum of */
+/* >          squares of elements N+1:M in that column. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,M,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JPVT */
+/* > \verbatim */
+/* >          JPVT is INTEGER array, dimension (N) */
+/* >          On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
+/* >          initial column, otherwise it is a free column.  Before */
+/* >          the QR factorization of A, all initial columns are */
+/* >          permuted to the leading positions; only the remaining */
+/* >          free columns are moved as a result of column pivoting */
+/* >          during the factorization. */
+/* >          On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* >          was the k-th column of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RCOND */
+/* > \verbatim */
+/* >          RCOND is DOUBLE PRECISION */
+/* >          RCOND is used to determine the effective rank of A, which */
+/* >          is defined as the order of the largest leading triangular */
+/* >          submatrix R11 in the QR factorization with pivoting of A, */
+/* >          whose estimated condition number < 1/RCOND. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RANK */
+/* > \verbatim */
+/* >          RANK is INTEGER */
+/* >          The effective rank of A, i.e., the order of the submatrix */
+/* >          R11.  This is the same as the order of the submatrix T11 */
+/* >          in the complete orthogonal factorization of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX*16 array, dimension */
+/* >                      (f2cmin(M,N) + f2cmax( N, 2*f2cmin(M,N)+NRHS )), */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RWORK */
+/* > \verbatim */
+/* >          RWORK is DOUBLE PRECISION array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16GEsolve */
+
+/*  ===================================================================== */
+/* Subroutine */ int zgelsx_(integer *m, integer *n, integer *nrhs, 
+	doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, 
+	integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, 
+	doublereal *rwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+    doublecomplex z__1;
+
+    /* Local variables */
+    doublereal anrm, bnrm, smin, smax;
+    integer i__, j, k, iascl, ibscl, ismin, ismax;
+    doublecomplex c1, c2, s1, s2, t1, t2;
+    extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *, 
+	    integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+	     doublecomplex *, integer *), 
+	    zlaic1_(integer *, integer *, doublecomplex *, doublereal *, 
+	    doublecomplex *, doublecomplex *, doublereal *, doublecomplex *, 
+	    doublecomplex *), dlabad_(doublereal *, doublereal *);
+    extern doublereal dlamch_(char *);
+    integer mn;
+    extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, 
+	    integer *, doublecomplex *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
+	    integer *, doublereal *);
+    doublereal bignum;
+    extern /* Subroutine */ int zlascl_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+	     integer *, integer *), zgeqpf_(integer *, integer *, 
+	    doublecomplex *, integer *, integer *, doublecomplex *, 
+	    doublecomplex *, doublereal *, integer *), zlaset_(char *, 
+	    integer *, integer *, doublecomplex *, doublecomplex *, 
+	    doublecomplex *, integer *);
+    doublereal sminpr, smaxpr, smlnum;
+    extern /* Subroutine */ int zlatzm_(char *, integer *, integer *, 
+	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *), ztzrqf_(
+	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+	     integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --jpvt;
+    --work;
+    --rwork;
+
+    /* Function Body */
+    mn = f2cmin(*m,*n);
+    ismin = mn + 1;
+    ismax = (mn << 1) + 1;
+
+/*     Test the input arguments. */
+
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -5;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = f2cmax(1,*m);
+	if (*ldb < f2cmax(i__1,*n)) {
+	    *info = -7;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("ZGELSX", &i__1);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+/* Computing MIN */
+    i__1 = f2cmin(*m,*n);
+    if (f2cmin(i__1,*nrhs) == 0) {
+	*rank = 0;
+	return 0;
+    }
+
+/*     Get machine parameters */
+
+    smlnum = dlamch_("S") / dlamch_("P");
+    bignum = 1. / smlnum;
+    dlabad_(&smlnum, &bignum);
+
+/*     Scale A, B if f2cmax elements outside range [SMLNUM,BIGNUM] */
+
+    anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+    iascl = 0;
+    if (anrm > 0. && anrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 1;
+    } else if (anrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 2;
+    } else if (anrm == 0.) {
+
+/*        Matrix all zero. Return zero solution. */
+
+	i__1 = f2cmax(*m,*n);
+	zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+	*rank = 0;
+	goto L100;
+    }
+
+    bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+    ibscl = 0;
+    if (bnrm > 0. && bnrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+		 info);
+	ibscl = 1;
+    } else if (bnrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+		 info);
+	ibscl = 2;
+    }
+
+/*     Compute QR factorization with column pivoting of A: */
+/*        A * P = Q * R */
+
+    zgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &
+	    rwork[1], info);
+
+/*     complex workspace MN+N. Real workspace 2*N. Details of Householder */
+/*     rotations stored in WORK(1:MN). */
+
+/*     Determine RANK using incremental condition estimation */
+
+    i__1 = ismin;
+    work[i__1].r = 1., work[i__1].i = 0.;
+    i__1 = ismax;
+    work[i__1].r = 1., work[i__1].i = 0.;
+    smax = z_abs(&a[a_dim1 + 1]);
+    smin = smax;
+    if (z_abs(&a[a_dim1 + 1]) == 0.) {
+	*rank = 0;
+	i__1 = f2cmax(*m,*n);
+	zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+	goto L100;
+    } else {
+	*rank = 1;
+    }
+
+L10:
+    if (*rank < mn) {
+	i__ = *rank + 1;
+	zlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+		i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+	zlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+		i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+	if (smaxpr * *rcond <= sminpr) {
+	    i__1 = *rank;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		i__2 = ismin + i__ - 1;
+		i__3 = ismin + i__ - 1;
+		z__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, z__1.i = 
+			s1.r * work[i__3].i + s1.i * work[i__3].r;
+		work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+		i__2 = ismax + i__ - 1;
+		i__3 = ismax + i__ - 1;
+		z__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, z__1.i = 
+			s2.r * work[i__3].i + s2.i * work[i__3].r;
+		work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L20: */
+	    }
+	    i__1 = ismin + *rank;
+	    work[i__1].r = c1.r, work[i__1].i = c1.i;
+	    i__1 = ismax + *rank;
+	    work[i__1].r = c2.r, work[i__1].i = c2.i;
+	    smin = sminpr;
+	    smax = smaxpr;
+	    ++(*rank);
+	    goto L10;
+	}
+    }
+
+/*     Logically partition R = [ R11 R12 ] */
+/*                             [  0  R22 ] */
+/*     where R11 = R(1:RANK,1:RANK) */
+
+/*     [R11,R12] = [ T11, 0 ] * Y */
+
+    if (*rank < *n) {
+	ztzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
+    }
+
+/*     Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/*     B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS) */
+
+    zunm2r_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, &
+	    work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], info);
+
+/*     workspace NRHS */
+
+/*      B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+    ztrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[
+	    a_offset], lda, &b[b_offset], ldb);
+
+    i__1 = *n;
+    for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+	i__2 = *nrhs;
+	for (j = 1; j <= i__2; ++j) {
+	    i__3 = i__ + j * b_dim1;
+	    b[i__3].r = 0., b[i__3].i = 0.;
+/* L30: */
+	}
+/* L40: */
+    }
+
+/*     B(1:N,1:NRHS) := Y**H * B(1:N,1:NRHS) */
+
+    if (*rank < *n) {
+	i__1 = *rank;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n - *rank + 1;
+	    d_cnjg(&z__1, &work[mn + i__]);
+	    zlatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, 
+		    &z__1, &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], ldb, &
+		    work[(mn << 1) + 1]);
+/* L50: */
+	}
+    }
+
+/*     workspace NRHS */
+
+/*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+    i__1 = *nrhs;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = (mn << 1) + i__;
+	    work[i__3].r = 1., work[i__3].i = 0.;
+/* L60: */
+	}
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = (mn << 1) + i__;
+	    if (work[i__3].r == 1. && work[i__3].i == 0.) {
+		if (jpvt[i__] != i__) {
+		    k = i__;
+		    i__3 = k + j * b_dim1;
+		    t1.r = b[i__3].r, t1.i = b[i__3].i;
+		    i__3 = jpvt[k] + j * b_dim1;
+		    t2.r = b[i__3].r, t2.i = b[i__3].i;
+L70:
+		    i__3 = jpvt[k] + j * b_dim1;
+		    b[i__3].r = t1.r, b[i__3].i = t1.i;
+		    i__3 = (mn << 1) + k;
+		    work[i__3].r = 0., work[i__3].i = 0.;
+		    t1.r = t2.r, t1.i = t2.i;
+		    k = jpvt[k];
+		    i__3 = jpvt[k] + j * b_dim1;
+		    t2.r = b[i__3].r, t2.i = b[i__3].i;
+		    if (jpvt[k] != i__) {
+			goto L70;
+		    }
+		    i__3 = i__ + j * b_dim1;
+		    b[i__3].r = t1.r, b[i__3].i = t1.i;
+		    i__3 = (mn << 1) + k;
+		    work[i__3].r = 0., work[i__3].i = 0.;
+		}
+	    }
+/* L80: */
+	}
+/* L90: */
+    }
+
+/*     Undo scaling */
+
+    if (iascl == 1) {
+	zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+		 info);
+	zlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], 
+		lda, info);
+    } else if (iascl == 2) {
+	zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+		 info);
+	zlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], 
+		lda, info);
+    }
+    if (ibscl == 1) {
+	zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+		 info);
+    } else if (ibscl == 2) {
+	zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+		 info);
+    }
+
+L100:
+
+    return 0;
+
+/*     End of ZGELSX */
+
+} /* zgelsx_ */
+

lapack-netlib/SRC/DEPRECATED/zgeqpf.c

@@ -0,0 +1,745 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* > \brief \b ZGEQPF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download ZGEQPF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeqpf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeqpf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeqpf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, M, N */
+/*       INTEGER            JPVT( * ) */
+/*       DOUBLE PRECISION   RWORK( * ) */
+/*       COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine ZGEQP3. */
+/* > */
+/* > ZGEQPF computes a QR factorization with column pivoting of a */
+/* > complex M-by-N matrix A: A*P = Q*R. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A. M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A. N >= 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, the upper triangle of the array contains the */
+/* >          f2cmin(M,N)-by-N upper triangular matrix R; the elements */
+/* >          below the diagonal, together with the array TAU, */
+/* >          represent the unitary matrix Q as a product of */
+/* >          f2cmin(m,n) elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JPVT */
+/* > \verbatim */
+/* >          JPVT is INTEGER array, dimension (N) */
+/* >          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* >          to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* >          the i-th column of A is a free column. */
+/* >          On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* >          was the k-th column of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */
+/* >          The scalar factors of the elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX*16 array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RWORK */
+/* > \verbatim */
+/* >          RWORK is DOUBLE PRECISION array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16GEcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The matrix Q is represented as a product of elementary reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(n) */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H = I - tau * v * v**H */
+/* > */
+/* >  where tau is a complex scalar, and v is a complex vector with */
+/* >  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
+/* > */
+/* >  The matrix P is represented in jpvt as follows: If */
+/* >     jpvt(j) = i */
+/* >  then the jth column of P is the ith canonical unit vector. */
+/* > */
+/* >  Partial column norm updating strategy modified by */
+/* >    Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* >    University of Zagreb, Croatia. */
+/* >  -- April 2011                                                      -- */
+/* >  For more details see LAPACK Working Note 176. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a, 
+	integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work, 
+	doublereal *rwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublereal d__1, d__2;
+    doublecomplex z__1;
+
+    /* Local variables */
+    doublereal temp, temp2;
+    integer i__, j;
+    doublereal tol3z;
+    integer itemp;
+    extern /* Subroutine */ int zlarf_(char *, integer *, integer *, 
+	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
+	    integer *, doublecomplex *), zswap_(integer *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
+	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+	     doublecomplex *, integer *);
+    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+    integer ma;
+    extern doublereal dlamch_(char *);
+    integer mn;
+    extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, 
+	    integer *, doublecomplex *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *);
+    extern integer idamax_(integer *, doublereal *, integer *);
+    extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
+	    integer *, doublecomplex *, doublecomplex *, integer *, 
+	    doublecomplex *);
+    doublecomplex aii;
+    integer pvt;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --jpvt;
+    --tau;
+    --work;
+    --rwork;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("ZGEQPF", &i__1);
+	return 0;
+    }
+
+    mn = f2cmin(*m,*n);
+    tol3z = sqrt(dlamch_("Epsilon"));
+
+/*     Move initial columns up front */
+
+    itemp = 1;
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (jpvt[i__] != 0) {
+	    if (i__ != itemp) {
+		zswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
+			 &c__1);
+		jpvt[i__] = jpvt[itemp];
+		jpvt[itemp] = i__;
+	    } else {
+		jpvt[i__] = i__;
+	    }
+	    ++itemp;
+	} else {
+	    jpvt[i__] = i__;
+	}
+/* L10: */
+    }
+    --itemp;
+
+/*     Compute the QR factorization and update remaining columns */
+
+    if (itemp > 0) {
+	ma = f2cmin(itemp,*m);
+	zgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
+	if (ma < *n) {
+	    i__1 = *n - ma;
+	    zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
+		    , lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], 
+		    info);
+	}
+    }
+
+    if (itemp < mn) {
+
+/*        Initialize partial column norms. The first n elements of */
+/*        work store the exact column norms. */
+
+	i__1 = *n;
+	for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+	    i__2 = *m - itemp;
+	    rwork[i__] = dznrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
+	    rwork[*n + i__] = rwork[i__];
+/* L20: */
+	}
+
+/*        Compute factorization */
+
+	i__1 = mn;
+	for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+
+/*           Determine ith pivot column and swap if necessary */
+
+	    i__2 = *n - i__ + 1;
+	    pvt = i__ - 1 + idamax_(&i__2, &rwork[i__], &c__1);
+
+	    if (pvt != i__) {
+		zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+			c__1);
+		itemp = jpvt[pvt];
+		jpvt[pvt] = jpvt[i__];
+		jpvt[i__] = itemp;
+		rwork[pvt] = rwork[i__];
+		rwork[*n + pvt] = rwork[*n + i__];
+	    }
+
+/*           Generate elementary reflector H(i) */
+
+	    i__2 = i__ + i__ * a_dim1;
+	    aii.r = a[i__2].r, aii.i = a[i__2].i;
+	    i__2 = *m - i__ + 1;
+/* Computing MIN */
+	    i__3 = i__ + 1;
+	    zlarfg_(&i__2, &aii, &a[f2cmin(i__3,*m) + i__ * a_dim1], &c__1, &tau[
+		    i__]);
+	    i__2 = i__ + i__ * a_dim1;
+	    a[i__2].r = aii.r, a[i__2].i = aii.i;
+
+	    if (i__ < *n) {
+
+/*              Apply H(i) to A(i:m,i+1:n) from the left */
+
+		i__2 = i__ + i__ * a_dim1;
+		aii.r = a[i__2].r, aii.i = a[i__2].i;
+		i__2 = i__ + i__ * a_dim1;
+		a[i__2].r = 1., a[i__2].i = 0.;
+		i__2 = *m - i__ + 1;
+		i__3 = *n - i__;
+		d_cnjg(&z__1, &tau[i__]);
+		zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+			z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+		i__2 = i__ + i__ * a_dim1;
+		a[i__2].r = aii.r, a[i__2].i = aii.i;
+	    }
+
+/*           Update partial column norms */
+
+	    i__2 = *n;
+	    for (j = i__ + 1; j <= i__2; ++j) {
+		if (rwork[j] != 0.) {
+
+/*                 NOTE: The following 4 lines follow from the analysis in */
+/*                 Lapack Working Note 176. */
+
+		    temp = z_abs(&a[i__ + j * a_dim1]) / rwork[j];
+/* Computing MAX */
+		    d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
+		    temp = f2cmax(d__1,d__2);
+/* Computing 2nd power */
+		    d__1 = rwork[j] / rwork[*n + j];
+		    temp2 = temp * (d__1 * d__1);
+		    if (temp2 <= tol3z) {
+			if (*m - i__ > 0) {
+			    i__3 = *m - i__;
+			    rwork[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
+				    , &c__1);
+			    rwork[*n + j] = rwork[j];
+			} else {
+			    rwork[j] = 0.;
+			    rwork[*n + j] = 0.;
+			}
+		    } else {
+			rwork[j] *= sqrt(temp);
+		    }
+		}
+/* L30: */
+	    }
+
+/* L40: */
+	}
+    }
+    return 0;
+
+/*     End of ZGEQPF */
+
+} /* zgeqpf_ */
+

lapack-netlib/SRC/DEPRECATED/zggsvd.c

@@ -0,0 +1,892 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* > \brief <b> ZGGSVD computes the singular value decomposition (SVD) for OTHER matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download ZGGSVD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zggsvd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zggsvd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zggsvd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, */
+/*                          LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, */
+/*                          RWORK, IWORK, INFO ) */
+
+/*       CHARACTER          JOBQ, JOBU, JOBV */
+/*       INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P */
+/*       INTEGER            IWORK( * ) */
+/*       DOUBLE PRECISION   ALPHA( * ), BETA( * ), RWORK( * ) */
+/*       COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */
+/*      $                   U( LDU, * ), V( LDV, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine ZGGSVD3. */
+/* > */
+/* > ZGGSVD computes the generalized singular value decomposition (GSVD) */
+/* > of an M-by-N complex matrix A and P-by-N complex matrix B: */
+/* > */
+/* >       U**H*A*Q = D1*( 0 R ),    V**H*B*Q = D2*( 0 R ) */
+/* > */
+/* > where U, V and Q are unitary matrices. */
+/* > Let K+L = the effective numerical rank of the */
+/* > matrix (A**H,B**H)**H, then R is a (K+L)-by-(K+L) nonsingular upper */
+/* > triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal" */
+/* > matrices and of the following structures, respectively: */
+/* > */
+/* > If M-K-L >= 0, */
+/* > */
+/* >                     K  L */
+/* >        D1 =     K ( I  0 ) */
+/* >                 L ( 0  C ) */
+/* >             M-K-L ( 0  0 ) */
+/* > */
+/* >                   K  L */
+/* >        D2 =   L ( 0  S ) */
+/* >             P-L ( 0  0 ) */
+/* > */
+/* >                 N-K-L  K    L */
+/* >   ( 0 R ) = K (  0   R11  R12 ) */
+/* >             L (  0    0   R22 ) */
+/* > where */
+/* > */
+/* >   C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* >   S = diag( BETA(K+1),  ... , BETA(K+L) ), */
+/* >   C**2 + S**2 = I. */
+/* > */
+/* >   R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+/* > */
+/* > If M-K-L < 0, */
+/* > */
+/* >                   K M-K K+L-M */
+/* >        D1 =   K ( I  0    0   ) */
+/* >             M-K ( 0  C    0   ) */
+/* > */
+/* >                     K M-K K+L-M */
+/* >        D2 =   M-K ( 0  S    0  ) */
+/* >             K+L-M ( 0  0    I  ) */
+/* >               P-L ( 0  0    0  ) */
+/* > */
+/* >                    N-K-L  K   M-K  K+L-M */
+/* >   ( 0 R ) =     K ( 0    R11  R12  R13  ) */
+/* >               M-K ( 0     0   R22  R23  ) */
+/* >             K+L-M ( 0     0    0   R33  ) */
+/* > */
+/* > where */
+/* > */
+/* >   C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* >   S = diag( BETA(K+1),  ... , BETA(M) ), */
+/* >   C**2 + S**2 = I. */
+/* > */
+/* >   (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */
+/* >   ( 0  R22 R23 ) */
+/* >   in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+/* > */
+/* > The routine computes C, S, R, and optionally the unitary */
+/* > transformation matrices U, V and Q. */
+/* > */
+/* > In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */
+/* > A and B implicitly gives the SVD of A*inv(B): */
+/* >                      A*inv(B) = U*(D1*inv(D2))*V**H. */
+/* > If ( A**H,B**H)**H has orthnormal columns, then the GSVD of A and B is also */
+/* > equal to the CS decomposition of A and B. Furthermore, the GSVD can */
+/* > be used to derive the solution of the eigenvalue problem: */
+/* >                      A**H*A x = lambda* B**H*B x. */
+/* > In some literature, the GSVD of A and B is presented in the form */
+/* >                  U**H*A*X = ( 0 D1 ),   V**H*B*X = ( 0 D2 ) */
+/* > where U and V are orthogonal and X is nonsingular, and D1 and D2 are */
+/* > ``diagonal''.  The former GSVD form can be converted to the latter */
+/* > form by taking the nonsingular matrix X as */
+/* > */
+/* >                       X = Q*(  I   0    ) */
+/* >                             (  0 inv(R) ) */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBU */
+/* > \verbatim */
+/* >          JOBU is CHARACTER*1 */
+/* >          = 'U':  Unitary matrix U is computed; */
+/* >          = 'N':  U is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBV */
+/* > \verbatim */
+/* >          JOBV is CHARACTER*1 */
+/* >          = 'V':  Unitary matrix V is computed; */
+/* >          = 'N':  V is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBQ */
+/* > \verbatim */
+/* >          JOBQ is CHARACTER*1 */
+/* >          = 'Q':  Unitary matrix Q is computed; */
+/* >          = 'N':  Q is not computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] P */
+/* > \verbatim */
+/* >          P is INTEGER */
+/* >          The number of rows of the matrix B.  P >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* > \endverbatim */
+/* > */
+/* > \param[out] L */
+/* > \verbatim */
+/* >          L is INTEGER */
+/* > */
+/* >          On exit, K and L specify the dimension of the subblocks */
+/* >          described in Purpose. */
+/* >          K + L = effective numerical rank of (A**H,B**H)**H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N) */
+/* >          On entry, the M-by-N matrix A. */
+/* >          On exit, A contains the triangular matrix R, or part of R. */
+/* >          See Purpose for details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is COMPLEX*16 array, dimension (LDB,N) */
+/* >          On entry, the P-by-N matrix B. */
+/* >          On exit, B contains part of the triangular matrix R if */
+/* >          M-K-L < 0.  See Purpose for details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B. LDB >= f2cmax(1,P). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is DOUBLE PRECISION array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] BETA */
+/* > \verbatim */
+/* >          BETA is DOUBLE PRECISION array, dimension (N) */
+/* > */
+/* >          On exit, ALPHA and BETA contain the generalized singular */
+/* >          value pairs of A and B; */
+/* >            ALPHA(1:K) = 1, */
+/* >            BETA(1:K)  = 0, */
+/* >          and if M-K-L >= 0, */
+/* >            ALPHA(K+1:K+L) = C, */
+/* >            BETA(K+1:K+L)  = S, */
+/* >          or if M-K-L < 0, */
+/* >            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */
+/* >            BETA(K+1:M) =S, BETA(M+1:K+L) =1 */
+/* >          and */
+/* >            ALPHA(K+L+1:N) = 0 */
+/* >            BETA(K+L+1:N)  = 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[out] U */
+/* > \verbatim */
+/* >          U is COMPLEX*16 array, dimension (LDU,M) */
+/* >          If JOBU = 'U', U contains the M-by-M unitary matrix U. */
+/* >          If JOBU = 'N', U is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDU */
+/* > \verbatim */
+/* >          LDU is INTEGER */
+/* >          The leading dimension of the array U. LDU >= f2cmax(1,M) if */
+/* >          JOBU = 'U'; LDU >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] V */
+/* > \verbatim */
+/* >          V is COMPLEX*16 array, dimension (LDV,P) */
+/* >          If JOBV = 'V', V contains the P-by-P unitary matrix V. */
+/* >          If JOBV = 'N', V is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDV */
+/* > \verbatim */
+/* >          LDV is INTEGER */
+/* >          The leading dimension of the array V. LDV >= f2cmax(1,P) if */
+/* >          JOBV = 'V'; LDV >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Q */
+/* > \verbatim */
+/* >          Q is COMPLEX*16 array, dimension (LDQ,N) */
+/* >          If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q. */
+/* >          If JOBQ = 'N', Q is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDQ */
+/* > \verbatim */
+/* >          LDQ is INTEGER */
+/* >          The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */
+/* >          JOBQ = 'Q'; LDQ >= 1 otherwise. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX*16 array, dimension (f2cmax(3*N,M,P)+N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RWORK */
+/* > \verbatim */
+/* >          RWORK is DOUBLE PRECISION array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* >          On exit, IWORK stores the sorting information. More */
+/* >          precisely, the following loop will sort ALPHA */
+/* >             for I = K+1, f2cmin(M,K+L) */
+/* >                 swap ALPHA(I) and ALPHA(IWORK(I)) */
+/* >             endfor */
+/* >          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit. */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* >          > 0:  if INFO = 1, the Jacobi-type procedure failed to */
+/* >                converge.  For further details, see subroutine ZTGSJA. */
+/* > \endverbatim */
+
+/* > \par Internal Parameters: */
+/*  ========================= */
+/* > */
+/* > \verbatim */
+/* >  TOLA    DOUBLE PRECISION */
+/* >  TOLB    DOUBLE PRECISION */
+/* >          TOLA and TOLB are the thresholds to determine the effective */
+/* >          rank of (A**H,B**H)**H. Generally, they are set to */
+/* >                   TOLA = MAX(M,N)*norm(A)*MAZHEPS, */
+/* >                   TOLB = MAX(P,N)*norm(B)*MAZHEPS. */
+/* >          The size of TOLA and TOLB may affect the size of backward */
+/* >          errors of the decomposition. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16OTHERsing */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* >     Ming Gu and Huan Ren, Computer Science Division, University of */
+/* >     California at Berkeley, USA */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int zggsvd_(char *jobu, char *jobv, char *jobq, integer *m, 
+	integer *n, integer *p, integer *k, integer *l, doublecomplex *a, 
+	integer *lda, doublecomplex *b, integer *ldb, doublereal *alpha, 
+	doublereal *beta, doublecomplex *u, integer *ldu, doublecomplex *v, 
+	integer *ldv, doublecomplex *q, integer *ldq, doublecomplex *work, 
+	doublereal *rwork, integer *iwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, 
+	    u_offset, v_dim1, v_offset, i__1, i__2;
+
+    /* Local variables */
+    integer ibnd;
+    doublereal tola;
+    integer isub;
+    doublereal tolb, unfl, temp, smax;
+    integer ncallmycycle, i__, j;
+    extern logical lsame_(char *, char *);
+    doublereal anorm, bnorm;
+    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
+	    doublereal *, integer *);
+    logical wantq, wantu, wantv;
+    extern doublereal dlamch_(char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
+	    integer *, doublereal *);
+    extern /* Subroutine */ int ztgsja_(char *, char *, char *, integer *, 
+	    integer *, integer *, integer *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+	     doublereal *, doublereal *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *, integer *), 
+	    zggsvp_(char *, char *, char *, integer *, integer *, integer *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+	     integer *, doublecomplex *, integer *, doublecomplex *, integer *
+	    , integer *, doublereal *, doublecomplex *, doublecomplex *, 
+	    integer *);
+    doublereal ulp;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Decode and test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --alpha;
+    --beta;
+    u_dim1 = *ldu;
+    u_offset = 1 + u_dim1 * 1;
+    u -= u_offset;
+    v_dim1 = *ldv;
+    v_offset = 1 + v_dim1 * 1;
+    v -= v_offset;
+    q_dim1 = *ldq;
+    q_offset = 1 + q_dim1 * 1;
+    q -= q_offset;
+    --work;
+    --rwork;
+    --iwork;
+
+    /* Function Body */
+    wantu = lsame_(jobu, "U");
+    wantv = lsame_(jobv, "V");
+    wantq = lsame_(jobq, "Q");
+
+    *info = 0;
+    if (! (wantu || lsame_(jobu, "N"))) {
+	*info = -1;
+    } else if (! (wantv || lsame_(jobv, "N"))) {
+	*info = -2;
+    } else if (! (wantq || lsame_(jobq, "N"))) {
+	*info = -3;
+    } else if (*m < 0) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -5;
+    } else if (*p < 0) {
+	*info = -6;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -10;
+    } else if (*ldb < f2cmax(1,*p)) {
+	*info = -12;
+    } else if (*ldu < 1 || wantu && *ldu < *m) {
+	*info = -16;
+    } else if (*ldv < 1 || wantv && *ldv < *p) {
+	*info = -18;
+    } else if (*ldq < 1 || wantq && *ldq < *n) {
+	*info = -20;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("ZGGSVD", &i__1);
+	return 0;
+    }
+
+/*     Compute the Frobenius norm of matrices A and B */
+
+    anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+    bnorm = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+
+/*     Get machine precision and set up threshold for determining */
+/*     the effective numerical rank of the matrices A and B. */
+
+    ulp = dlamch_("Precision");
+    unfl = dlamch_("Safe Minimum");
+    tola = f2cmax(*m,*n) * f2cmax(anorm,unfl) * ulp;
+    tolb = f2cmax(*p,*n) * f2cmax(bnorm,unfl) * ulp;
+
+    zggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, &
+	    tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[
+	    q_offset], ldq, &iwork[1], &rwork[1], &work[1], &work[*n + 1], 
+	    info);
+
+/*     Compute the GSVD of two upper "triangular" matrices */
+
+    ztgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], 
+	    ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+	    v_offset], ldv, &q[q_offset], ldq, &work[1], &ncallmycycle, info);
+
+/*     Sort the singular values and store the pivot indices in IWORK */
+/*     Copy ALPHA to RWORK, then sort ALPHA in RWORK */
+
+    dcopy_(n, &alpha[1], &c__1, &rwork[1], &c__1);
+/* Computing MIN */
+    i__1 = *l, i__2 = *m - *k;
+    ibnd = f2cmin(i__1,i__2);
+    i__1 = ibnd;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        Scan for largest ALPHA(K+I) */
+
+	isub = i__;
+	smax = rwork[*k + i__];
+	i__2 = ibnd;
+	for (j = i__ + 1; j <= i__2; ++j) {
+	    temp = rwork[*k + j];
+	    if (temp > smax) {
+		isub = j;
+		smax = temp;
+	    }
+/* L10: */
+	}
+	if (isub != i__) {
+	    rwork[*k + isub] = rwork[*k + i__];
+	    rwork[*k + i__] = smax;
+	    iwork[*k + i__] = *k + isub;
+	} else {
+	    iwork[*k + i__] = *k + i__;
+	}
+/* L20: */
+    }
+
+    return 0;
+
+/*     End of ZGGSVD */
+
+} /* zggsvd_ */
+

lapack-netlib/SRC/DEPRECATED/zlahrd.c

@@ -0,0 +1,737 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* > \brief \b ZLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below th
+e k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformati
+on to the unreduced part of A. */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download ZLAHRD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahrd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahrd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahrd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */
+
+/*       INTEGER            K, LDA, LDT, LDY, N, NB */
+/*       COMPLEX*16         A( LDA, * ), T( LDT, NB ), TAU( NB ), */
+/*      $                   Y( LDY, NB ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine ZLAHR2. */
+/* > */
+/* > ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) */
+/* > matrix A so that elements below the k-th subdiagonal are zero. The */
+/* > reduction is performed by a unitary similarity transformation */
+/* > Q**H * A * Q. The routine returns the matrices V and T which determine */
+/* > Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The offset for the reduction. Elements below the k-th */
+/* >          subdiagonal in the first NB columns are reduced to zero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NB */
+/* > \verbatim */
+/* >          NB is INTEGER */
+/* >          The number of columns to be reduced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N-K+1) */
+/* >          On entry, the n-by-(n-k+1) general matrix A. */
+/* >          On exit, the elements on and above the k-th subdiagonal in */
+/* >          the first NB columns are overwritten with the corresponding */
+/* >          elements of the reduced matrix; the elements below the k-th */
+/* >          subdiagonal, with the array TAU, represent the matrix Q as a */
+/* >          product of elementary reflectors. The other columns of A are */
+/* >          unchanged. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is COMPLEX*16 array, dimension (NB) */
+/* >          The scalar factors of the elementary reflectors. See Further */
+/* >          Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] T */
+/* > \verbatim */
+/* >          T is COMPLEX*16 array, dimension (LDT,NB) */
+/* >          The upper triangular matrix T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDT */
+/* > \verbatim */
+/* >          LDT is INTEGER */
+/* >          The leading dimension of the array T.  LDT >= NB. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Y */
+/* > \verbatim */
+/* >          Y is COMPLEX*16 array, dimension (LDY,NB) */
+/* >          The n-by-nb matrix Y. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDY */
+/* > \verbatim */
+/* >          LDY is INTEGER */
+/* >          The leading dimension of the array Y. LDY >= f2cmax(1,N). */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16OTHERauxiliary */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The matrix Q is represented as a product of nb elementary reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(nb). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**H */
+/* > */
+/* >  where tau is a complex scalar, and v is a complex vector with */
+/* >  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* >  A(i+k+1:n,i), and tau in TAU(i). */
+/* > */
+/* >  The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* >  V which is needed, with T and Y, to apply the transformation to the */
+/* >  unreduced part of the matrix, using an update of the form: */
+/* >  A := (I - V*T*V**H) * (A - Y*V**H). */
+/* > */
+/* >  The contents of A on exit are illustrated by the following example */
+/* >  with n = 7, k = 3 and nb = 2: */
+/* > */
+/* >     ( a   h   a   a   a ) */
+/* >     ( a   h   a   a   a ) */
+/* >     ( a   h   a   a   a ) */
+/* >     ( h   h   a   a   a ) */
+/* >     ( v1  h   a   a   a ) */
+/* >     ( v1  v2  a   a   a ) */
+/* >     ( v1  v2  a   a   a ) */
+/* > */
+/* >  where a denotes an element of the original matrix A, h denotes a */
+/* >  modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* >  element of the vector defining H(i). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int zlahrd_(integer *n, integer *k, integer *nb, 
+	doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t, 
+	integer *ldt, doublecomplex *y, integer *ldy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, 
+	    i__3;
+    doublecomplex z__1;
+
+    /* Local variables */
+    integer i__;
+    extern /* Subroutine */ int zscal_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *), zgemv_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *), 
+	    zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, 
+	    integer *, doublecomplex *, integer *), ztrmv_(char *, char *, 
+	    char *, integer *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *);
+    doublecomplex ei;
+    extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *, 
+	    doublecomplex *, integer *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Quick return if possible */
+
+    /* Parameter adjustments */
+    --tau;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    t_dim1 = *ldt;
+    t_offset = 1 + t_dim1 * 1;
+    t -= t_offset;
+    y_dim1 = *ldy;
+    y_offset = 1 + y_dim1 * 1;
+    y -= y_offset;
+
+    /* Function Body */
+    if (*n <= 1) {
+	return 0;
+    }
+
+    i__1 = *nb;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (i__ > 1) {
+
+/*           Update A(1:n,i) */
+
+/*           Compute i-th column of A - Y * V**H */
+
+	    i__2 = i__ - 1;
+	    zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+	    i__2 = i__ - 1;
+	    z__1.r = -1., z__1.i = 0.;
+	    zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &a[*k 
+		    + i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], &
+		    c__1);
+	    i__2 = i__ - 1;
+	    zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+
+/*           Apply I - V * T**H * V**H to this column (call it b) from the */
+/*           left, using the last column of T as workspace */
+
+/*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows) */
+/*                    ( V2 )             ( b2 ) */
+
+/*           where V1 is unit lower triangular */
+
+/*           w := V1**H * b1 */
+
+	    i__2 = i__ - 1;
+	    zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + 
+		    1], &c__1);
+	    i__2 = i__ - 1;
+	    ztrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 + 
+		    a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/*           w := w + V2**H *b2 */
+
+	    i__2 = *n - *k - i__ + 1;
+	    i__3 = i__ - 1;
+	    zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + 
+		    a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
+		    t[*nb * t_dim1 + 1], &c__1);
+
+/*           w := T**H *w */
+
+	    i__2 = i__ - 1;
+	    ztrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[
+		    t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
+
+/*           b2 := b2 - V2*w */
+
+	    i__2 = *n - *k - i__ + 1;
+	    i__3 = i__ - 1;
+	    z__1.r = -1., z__1.i = 0.;
+	    zgemv_("No transpose", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1],
+		     lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ + 
+		    i__ * a_dim1], &c__1);
+
+/*           b1 := b1 - V1*w */
+
+	    i__2 = i__ - 1;
+	    ztrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
+		    , lda, &t[*nb * t_dim1 + 1], &c__1);
+	    i__2 = i__ - 1;
+	    z__1.r = -1., z__1.i = 0.;
+	    zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ 
+		    * a_dim1], &c__1);
+
+	    i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
+	    a[i__2].r = ei.r, a[i__2].i = ei.i;
+	}
+
+/*        Generate the elementary reflector H(i) to annihilate */
+/*        A(k+i+1:n,i) */
+
+	i__2 = *k + i__ + i__ * a_dim1;
+	ei.r = a[i__2].r, ei.i = a[i__2].i;
+	i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+	i__3 = *k + i__ + 1;
+	zlarfg_(&i__2, &ei, &a[f2cmin(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__])
+		;
+	i__2 = *k + i__ + i__ * a_dim1;
+	a[i__2].r = 1., a[i__2].i = 0.;
+
+/*        Compute  Y(1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	zgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1], 
+		lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ * 
+		y_dim1 + 1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = i__ - 1;
+	zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + 
+		a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
+		i__ * t_dim1 + 1], &c__1);
+	i__2 = i__ - 1;
+	z__1.r = -1., z__1.i = 0.;
+	zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &t[i__ * 
+		t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1);
+	zscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
+
+/*        Compute T(1:i,i) */
+
+	i__2 = i__ - 1;
+	i__3 = i__;
+	z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
+	zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1);
+	i__2 = i__ - 1;
+	ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, 
+		&t[i__ * t_dim1 + 1], &c__1)
+		;
+	i__2 = i__ + i__ * t_dim1;
+	i__3 = i__;
+	t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
+
+/* L10: */
+    }
+    i__1 = *k + *nb + *nb * a_dim1;
+    a[i__1].r = ei.r, a[i__1].i = ei.i;
+
+    return 0;
+
+/*     End of ZLAHRD */
+
+} /* zlahrd_ */
+

lapack-netlib/SRC/DEPRECATED/zlatzm.c

@@ -0,0 +1,631 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* > \brief \b ZLATZM */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download ZLATZM + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatzm.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatzm.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatzm.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) */
+
+/*       CHARACTER          SIDE */
+/*       INTEGER            INCV, LDC, M, N */
+/*       COMPLEX*16         TAU */
+/*       COMPLEX*16         C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine ZUNMRZ. */
+/* > */
+/* > ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix. */
+/* > */
+/* > Let P = I - tau*u*u**H,   u = ( 1 ), */
+/* >                               ( v ) */
+/* > where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
+/* > SIDE = 'R'. */
+/* > */
+/* > If SIDE equals 'L', let */
+/* >        C = [ C1 ] 1 */
+/* >            [ C2 ] m-1 */
+/* >              n */
+/* > Then C is overwritten by P*C. */
+/* > */
+/* > If SIDE equals 'R', let */
+/* >        C = [ C1, C2 ] m */
+/* >               1  n-1 */
+/* > Then C is overwritten by C*P. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* >          SIDE is CHARACTER*1 */
+/* >          = 'L': form P * C */
+/* >          = 'R': form C * P */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* >          V is COMPLEX*16 array, dimension */
+/* >                  (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* >                  (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* >          The vector v in the representation of P. V is not used */
+/* >          if TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* >          INCV is INTEGER */
+/* >          The increment between elements of v. INCV <> 0 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* >          TAU is COMPLEX*16 */
+/* >          The value tau in the representation of P. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C1 */
+/* > \verbatim */
+/* >          C1 is COMPLEX*16 array, dimension */
+/* >                         (LDC,N) if SIDE = 'L' */
+/* >                         (M,1)   if SIDE = 'R' */
+/* >          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
+/* >          if SIDE = 'R'. */
+/* > */
+/* >          On exit, the first row of P*C if SIDE = 'L', or the first */
+/* >          column of C*P if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C2 */
+/* > \verbatim */
+/* >          C2 is COMPLEX*16 array, dimension */
+/* >                         (LDC, N)   if SIDE = 'L' */
+/* >                         (LDC, N-1) if SIDE = 'R' */
+/* >          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
+/* >          m x (n - 1) matrix C2 if SIDE = 'R'. */
+/* > */
+/* >          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
+/* >          if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* >          LDC is INTEGER */
+/* >          The leading dimension of the arrays C1 and C2. */
+/* >          LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX*16 array, dimension */
+/* >                      (N) if SIDE = 'L' */
+/* >                      (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16OTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n, 
+	doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
+	c1, doublecomplex *c2, integer *ldc, doublecomplex *work)
+{
+    /* System generated locals */
+    integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
+    doublecomplex z__1;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zgemv_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *), 
+	    zgeru_(integer *, integer *, doublecomplex *, doublecomplex *, 
+	    integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+	    , zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, 
+	    integer *, doublecomplex *, integer *), zlacgv_(integer *, 
+	    doublecomplex *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    --v;
+    c2_dim1 = *ldc;
+    c2_offset = 1 + c2_dim1 * 1;
+    c2 -= c2_offset;
+    c1_dim1 = *ldc;
+    c1_offset = 1 + c1_dim1 * 1;
+    c1 -= c1_offset;
+    --work;
+
+    /* Function Body */
+    if (f2cmin(*m,*n) == 0 || tau->r == 0. && tau->i == 0.) {
+	return 0;
+    }
+
+    if (lsame_(side, "L")) {
+
+/*        w :=  ( C1 + v**H * C2 )**H */
+
+	zcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
+	zlacgv_(n, &work[1], &c__1);
+	i__1 = *m - 1;
+	zgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, &
+		v[1], incv, &c_b1, &work[1], &c__1);
+
+/*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w**H */
+/*        [ C2 ]    [ C2 ]        [ v ] */
+
+	zlacgv_(n, &work[1], &c__1);
+	z__1.r = -tau->r, z__1.i = -tau->i;
+	zaxpy_(n, &z__1, &work[1], &c__1, &c1[c1_offset], ldc);
+	i__1 = *m - 1;
+	z__1.r = -tau->r, z__1.i = -tau->i;
+	zgeru_(&i__1, n, &z__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], 
+		ldc);
+
+    } else if (lsame_(side, "R")) {
+
+/*        w := C1 + C2 * v */
+
+	zcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
+	i__1 = *n - 1;
+	zgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1], 
+		incv, &c_b1, &work[1], &c__1);
+
+/*        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**H] */
+
+	z__1.r = -tau->r, z__1.i = -tau->i;
+	zaxpy_(m, &z__1, &work[1], &c__1, &c1[c1_offset], &c__1);
+	i__1 = *n - 1;
+	z__1.r = -tau->r, z__1.i = -tau->i;
+	zgerc_(m, &i__1, &z__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], 
+		ldc);
+    }
+
+    return 0;
+
+/*     End of ZLATZM */
+
+} /* zlatzm_ */
+

lapack-netlib/SRC/DEPRECATED/ztzrqf.c

@@ -0,0 +1,662 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle() continue;
+#define myceiling(w) {ceil(w)}
+#define myhuge(w) {HUGE_VAL}
+#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex float cpow_ui(_Complex float x, integer n) {
+	_Complex float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static _Complex double zpow_ui(_Complex double x, integer n) {
+	_Complex double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer pow_ii(integer x, integer n) {
+	integer pow; unsigned long int u;
+	if (n <= 0) {
+		if (n == 0 || x == 1) pow = 1;
+		else if (x != -1) pow = x == 0 ? 1/x : 0;
+		else n = -n;
+	}
+	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+		u = n;
+		for(pow = 1; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
+{
+	double m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
+{
+	float m; integer i, mi;
+	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+		if (w[i-1]>m) mi=i ,m=w[i-1];
+	return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}	
+static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex float zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i]) * Cf(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+		}
+	}
+	pCf(z) = zdotc;
+}
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+	integer n = *n_, incx = *incx_, incy = *incy_, i;
+	_Complex double zdotc = 0.0;
+	if (incx == 1 && incy == 1) {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i]) * Cd(&y[i]);
+		}
+	} else {
+		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+		}
+	}
+	pCd(z) = zdotc;
+}
+#endif
+/*  -- translated by f2c (version 20000121).
+   You must link the resulting object file with the libraries:
+	-lf2c -lm   (in that order)
+*/
+
+
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* > \brief \b ZTZRQF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download ZTZRQF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztzrqf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztzrqf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztzrqf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO ) */
+
+/*       INTEGER            INFO, LDA, M, N */
+/*       COMPLEX*16         A( LDA, * ), TAU( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > This routine is deprecated and has been replaced by routine ZTZRZF. */
+/* > */
+/* > ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
+/* > to upper triangular form by means of unitary transformations. */
+/* > */
+/* > The upper trapezoidal matrix A is factored as */
+/* > */
+/* >    A = ( R  0 ) * Z, */
+/* > */
+/* > where Z is an N-by-N unitary matrix and R is an M-by-M upper */
+/* > triangular matrix. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of the matrix A.  M >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of the matrix A.  N >= M. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N) */
+/* >          On entry, the leading M-by-N upper trapezoidal part of the */
+/* >          array A must contain the matrix to be factorized. */
+/* >          On exit, the leading M-by-M upper triangular part of A */
+/* >          contains the upper triangular matrix R, and elements M+1 to */
+/* >          N of the first M rows of A, with the array TAU, represent the */
+/* >          unitary matrix Z as a product of M elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is COMPLEX*16 array, dimension (M) */
+/* >          The scalar factors of the elementary reflectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16OTHERcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The  factorization is obtained by Householder's method.  The kth */
+/* >  transformation matrix, Z( k ), whose conjugate transpose is used to */
+/* >  introduce zeros into the (m - k + 1)th row of A, is given in the form */
+/* > */
+/* >     Z( k ) = ( I     0   ), */
+/* >              ( 0  T( k ) ) */
+/* > */
+/* >  where */
+/* > */
+/* >     T( k ) = I - tau*u( k )*u( k )**H,   u( k ) = (   1    ), */
+/* >                                                   (   0    ) */
+/* >                                                   ( z( k ) ) */
+/* > */
+/* >  tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* >  tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* >  of X. */
+/* > */
+/* >  The scalar tau is returned in the kth element of TAU and the vector */
+/* >  u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* >  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* >  the upper triangular part of A. */
+/* > */
+/* >  Z is given by */
+/* > */
+/* >     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ztzrqf_(integer *m, integer *n, doublecomplex *a, 
+	integer *lda, doublecomplex *tau, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    doublecomplex z__1, z__2;
+
+    /* Local variables */
+    integer i__, k;
+    doublecomplex alpha;
+    extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zgemv_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *);
+    integer m1;
+    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(
+	    char *, integer *), zlarfg_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *, 
+	    doublecomplex *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/* ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --tau;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < *m) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("ZTZRQF", &i__1);
+	return 0;
+    }
+
+/*     Perform the factorization. */
+
+    if (*m == 0) {
+	return 0;
+    }
+    if (*m == *n) {
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = i__;
+	    tau[i__2].r = 0., tau[i__2].i = 0.;
+/* L10: */
+	}
+    } else {
+/* Computing MIN */
+	i__1 = *m + 1;
+	m1 = f2cmin(i__1,*n);
+	for (k = *m; k >= 1; --k) {
+
+/*           Use a Householder reflection to zero the kth row of A. */
+/*           First set up the reflection. */
+
+	    i__1 = k + k * a_dim1;
+	    d_cnjg(&z__1, &a[k + k * a_dim1]);
+	    a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+	    i__1 = *n - *m;
+	    zlacgv_(&i__1, &a[k + m1 * a_dim1], lda);
+	    i__1 = k + k * a_dim1;
+	    alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+	    i__1 = *n - *m + 1;
+	    zlarfg_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]);
+	    i__1 = k + k * a_dim1;
+	    a[i__1].r = alpha.r, a[i__1].i = alpha.i;
+	    i__1 = k;
+	    d_cnjg(&z__1, &tau[k]);
+	    tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
+
+	    i__1 = k;
+	    if ((tau[i__1].r != 0. || tau[i__1].i != 0.) && k > 1) {
+
+/*              We now perform the operation  A := A*P( k )**H. */
+
+/*              Use the first ( k - 1 ) elements of TAU to store  a( k ), */
+/*              where  a( k ) consists of the first ( k - 1 ) elements of */
+/*              the  kth column  of  A.  Also  let  B  denote  the  first */
+/*              ( k - 1 ) rows of the last ( n - m ) columns of A. */
+
+		i__1 = k - 1;
+		zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
+
+/*              Form   w = a( k ) + B*z( k )  in TAU. */
+
+		i__1 = k - 1;
+		i__2 = *n - *m;
+		zgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 + 
+			1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], &
+			c__1);
+
+/*              Now form  a( k ) := a( k ) - conjg(tau)*w */
+/*              and       B      := B      - conjg(tau)*w*z( k )**H. */
+
+		i__1 = k - 1;
+		d_cnjg(&z__2, &tau[k]);
+		z__1.r = -z__2.r, z__1.i = -z__2.i;
+		zaxpy_(&i__1, &z__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
+			c__1);
+		i__1 = k - 1;
+		i__2 = *n - *m;
+		d_cnjg(&z__2, &tau[k]);
+		z__1.r = -z__2.r, z__1.i = -z__2.i;
+		zgerc_(&i__1, &i__2, &z__1, &tau[1], &c__1, &a[k + m1 * 
+			a_dim1], lda, &a[m1 * a_dim1 + 1], lda);
+	    }
+/* L20: */
+	}
+    }
+
+    return 0;
+
+/*     End of ZTZRQF */
+
+} /* ztzrqf_ */
+